diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 68be9c9b06..d660436783 100755 --- a/core/assocs/assocs-docs.factor +++ b/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 diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index c39010f228..82f0db1364 100755 --- a/core/kernel/kernel-docs.factor +++ b/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" } -"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" -{ $code "[ L ] unless*" "L or" } } ; +{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ; 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 -- )" } } } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 0dc834ad6b..314d9697e7 100755 --- a/core/syntax/syntax-docs.factor +++ b/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 \\ execute\n0 " } } ; +{ $examples "The following two lines are equivalent:" { $code "0 \\ execute\n0 " } "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: diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index b42c47d79b..691bcb866e 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -13,21 +13,23 @@ IN: cairo.gadgets >r first2 over width>stride [ * nip dup CAIRO_FORMAT_ARGB32 ] [ cairo_image_surface_create_for_data ] 3bi - r> with-cairo-from-surface ; + r> with-cairo-from-surface ; inline -TUPLE: cairo-gadget < texture-gadget quot ; +TUPLE: cairo-gadget < texture-gadget dim quot ; : ( dim quot -- gadget ) cairo-gadget construct-gadget swap >>quot swap >>dim ; -M: cairo-gadget format>> drop GL_BGRA ; +M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ; -M: cairo-gadget render* ( gadget -- ) - dup - [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi - >>bytes call-next-method ; +: render-cairo ( dim quot -- bytes format ) + >r 2^-bounds r> copy-cairo GL_BGRA ; + +M: cairo-gadget render* + [ dim>> dup ] [ quot>> ] bi + render-cairo render-bytes* ; ! maybe also texture>png ! : cairo>png ( gadget path -- ) @@ -40,11 +42,16 @@ M: cairo-gadget render* ( gadget -- ) cr swap 0 0 cairo_set_source_surface cr cairo_paint ; -: ( path -- gadget ) - normalize-path cairo_image_surface_create_from_png +TUPLE: png-gadget < texture-gadget path ; +: ( path -- gadget ) + png-gadget construct-gadget + swap >>path ; + +M: png-gadget render* + path>> normalize-path cairo_image_surface_create_from_png [ cairo_image_surface_get_width ] [ cairo_image_surface_get_height 2array dup 2^-bounds ] [ [ copy-surface ] curry copy-cairo ] tri - GL_BGRA rot ; - + GL_BGRA render-bytes* ; +M: png-gadget cache-key* path>> ; diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor index f34bdc9920..8572a8bd91 100755 --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -155,6 +155,16 @@ C-STRUCT: face { "face-size*" "size" } { "void*" "charmap" } ; +C-STRUCT: FT_Bitmap + { "int" "rows" } + { "int" "width" } + { "int" "pitch" } + { "void*" "buffer" } + { "short" "num_grays" } + { "char" "pixel_mode" } + { "char" "palette_mode" } + { "void*" "palette" } ; + FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ; FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ; @@ -170,6 +180,15 @@ C-ENUM: FT_RENDER_MODE_LCD FT_RENDER_MODE_LCD_V ; +C-ENUM: + FT_PIXEL_MODE_NONE + FT_PIXEL_MODE_MONO + FT_PIXEL_MODE_GRAY + FT_PIXEL_MODE_GRAY2 + FT_PIXEL_MODE_GRAY4 + FT_PIXEL_MODE_LCD + FT_PIXEL_MODE_LCD_V ; + FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ; FUNCTION: void FT_Done_Face ( face* face ) ; @@ -177,3 +196,4 @@ FUNCTION: void FT_Done_Face ( face* face ) ; FUNCTION: void FT_Done_FreeType ( void* library ) ; FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ; + diff --git a/extra/furnace/actions/actions-tests.factor b/extra/furnace/actions/actions-tests.factor index 8aa0f92b97..60a526fb24 100755 --- a/extra/furnace/actions/actions-tests.factor +++ b/extra/furnace/actions/actions-tests.factor @@ -21,3 +21,21 @@ blah init-request { } "action-1" get call-responder ] unit-test + + + "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 diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 5e237b02a8..1cef8e24e5 100755 --- a/extra/furnace/actions/actions.factor +++ b/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 new-action ; +: flashed-variables ( -- seq ) + { validation-messages named-validation-messages } ; + : handle-get ( action -- response ) - blank-values - [ init>> call ] - [ display>> call ] - bi ; + '[ + , + [ init>> call ] + [ drop flashed-variables restore-flash ] + [ display>> call ] + tri + ] with-exit-continuation ; : validation-failed ( -- * ) - request get method>> "POST" = - [ action get display>> call ] [ <400> ] if exit-with ; + request get method>> "POST" = [ f ] [ <400> ] if exit-with ; -: handle-post ( action -- response ) - init-validation - 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 ; +: (handle-post) ( action -- response ) + [ validate>> call ] [ submit>> call ] bi ; : 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 ] [ <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 ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor new file mode 100644 index 0000000000..f6b4e2c15f --- /dev/null +++ b/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 + +: 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 ] } + { "HEAD" [ drop ] } + { "POST" [ end-aside-post ] } + } case + ] [ ] ?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 ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 58ab47e3e1..d0c4e00953 100755 --- a/extra/furnace/auth/login/login.factor +++ b/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 : ( -- 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 [ f set-uid - URL" $login" end-flow + URL" $login" end-aside ] >>submit ; ! ! ! Authentication logic - -TUPLE: protected < filter-responder capabilities ; - -C: protected +: ( responder -- protected ) + protected new + swap >>responder ; : show-login-page ( -- response ) - begin-flow - URL" $login/login" ; + begin-aside + URL" $login/login" { protected } ; : 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 ) - f + + "edit your profile" >>description + "edit-profile" add-responder ; : allow-registration ( login -- login ) diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index a52aed59d7..a7ac92bf44 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -4,6 +4,19 @@ Login + +

You must log in to .

+ + + +

Your user must have the following capabilities:

+
    + +
    • +     +
+ + diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor new file mode 100644 index 0000000000..21fd20ccb4 --- /dev/null +++ b/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 + +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 ; + +: ( url seq -- response ) + make-flash-scope + [ clone ] dip flash-id-key set-query-param + ; + +: restore-flash ( seq -- ) + [ flash-scope get key? ] filter [ [ fget ] keep set ] each ; diff --git a/extra/furnace/flows/flows.factor b/extra/furnace/flows/flows.factor deleted file mode 100644 index eb98c1a26b..0000000000 --- a/extra/furnace/flows/flows.factor +++ /dev/null @@ -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 - -: 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 ] } - { "HEAD" [ drop ] } - { "POST" [ end-flow-post ] } - } case - ] [ ] ?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 [ - - ] when* ; diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index 5cf2dad9ad..223b20455d 100644 --- a/extra/furnace/furnace-tests.factor +++ b/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 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 + +[ "" ] +[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] +unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 370c4f84a3..862ed80e11 100644 --- a/extra/furnace/furnace.factor +++ b/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 -fry urls multiline +vocabs.loader classes strings +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 ; + : ( url -- response ) adjust-url request get method>> { { "GET" [ ] } @@ -64,15 +69,19 @@ M: object modify-query drop ; { "POST" [ ] } } 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 @@ -128,20 +137,34 @@ CHLOE: a [ drop ] tri ; +: hidden-form-field ( value name -- ) + over [ + + ] [ 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 -- ) [ [
- ] [ - [ hidden-form-field ] each-responder - "for" optional-attr [ hidden render ] when* - ] bi + ] + [ form-magic ] 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 ; diff --git a/extra/furnace/rss/rss.factor b/extra/furnace/rss/rss.factor deleted file mode 100644 index a94ef4fe51..0000000000 --- a/extra/furnace/rss/rss.factor +++ /dev/null @@ -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 - -: ( body -- response ) - feed>xml "application/atom+xml" ; - -TUPLE: feed-action < action feed ; - -: ( -- feed ) - feed-action new-action - dup '[ , feed>> call ] >>display ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 5ea389c87e..16fefe42fc 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/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 put-cookie ; -M: sessions hidden-form-field ( responder -- ) - drop - > number>string =value - input/> ; +M: sessions modify-form ( responder -- ) + drop session get id>> session-id-key hidden-form-field ; M: sessions call-responder* ( path responder -- response ) sessions set diff --git a/extra/furnace/syndication/syndication.factor b/extra/furnace/syndication/syndication.factor new file mode 100644 index 0000000000..7f60bcc746 --- /dev/null +++ b/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 + + 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 ; + +: ( body -- response ) + feed>xml "application/atom+xml" ; + +TUPLE: feed-action < action title url entries ; + +: ( -- 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 + + ] >>display ; diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index 4fa56bcf93..d131946ffb 100755 --- a/extra/globs/globs.factor +++ b/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 diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 1f77768115..2ae120b527 100644 --- a/extra/html/components/components-tests.factor +++ b/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 diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index c013007a14..72dabad84e 100644 --- a/extra/html/components/components.factor +++ b/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 -- ) [ ] 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 -- ) - '[ "value" set-value @ ] with-each-index ; inline +: with-each-object ( name quot -- ) + [ value ] dip '[ + [ + blank-values + 1+ "index" set-value + from-object + @ + ] with-scope + ] each-index ; inline -: with-each-object ( seq quot -- ) - '[ from-object @ ] with-each-index ; inline +SYMBOL: nested-values -: with-values ( object quot -- ) - '[ blank-values , from-object @ ] with-scope ; inline +: with-values ( name quot -- ) + '[ + , + [ 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 -- ) string =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 -- ) 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* ; ! Choice @@ -126,7 +140,7 @@ TUPLE: choice size multiple choices ; : render-option ( text selected? -- ) ; : render-options ( options selected -- ) @@ -135,7 +149,7 @@ TUPLE: choice size multiple choices ; M: choice render* " ] [ + [ + "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 + +[ "
RBaxterUnknown
" ] [ + [ + "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 + +[ "ab" ] [ + [ + "test12" test-template call-template + ] run-template +] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 9e0aa3fe1d..08d6b873fc 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/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 ; diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml new file mode 100644 index 0000000000..33fe2008a5 --- /dev/null +++ b/extra/html/templates/chloe/test/test10.xml @@ -0,0 +1,3 @@ + + + diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml new file mode 100644 index 0000000000..f74256bd84 --- /dev/null +++ b/extra/html/templates/chloe/test/test11.xml @@ -0,0 +1,14 @@ + + + + + + + + + + + +
+ + diff --git a/extra/html/templates/chloe/test/test12.xml b/extra/html/templates/chloe/test/test12.xml new file mode 100644 index 0000000000..b26778c96e --- /dev/null +++ b/extra/html/templates/chloe/test/test12.xml @@ -0,0 +1,3 @@ + + + diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 471d7e276b..c1d5b46aa4 100755 --- a/extra/http/http-tests.factor +++ b/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" } } - post-data: "blah" + header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } + 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 [ [ ] [ [ - f + "" 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 + +[ ] [ + [ + + + [ a get-global "a" set-value ] >>init + [ [ "a" render ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action + test-db + 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/" "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/" "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 diff --git a/extra/http/http.factor b/extra/http/http.factor index e8f7189f75..abbf79f860 100755 --- a/extra/http/http.factor +++ b/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 string? ] [ ] } - { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + { [ dup array? ] [ [ header-value>string ] map "; " join ] } + [ present ] } 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 +: ( raw content-type -- post-data ) + post-data new + swap >>content-type + swap >>raw ; -: content-length ( header -- n ) - "content-length" swap at string>number dup [ - dup max-post-request get > [ - "content-length > max-post-request" throw - ] when - ] when ; +: parse-post-data ( post-data -- post-data ) + [ ] [ raw>> ] [ content-type>> ] tri { + { "application/x-www-form-urlencoded" [ query>assoc ] } + { "text/xml" [ string>xml ] } + [ drop ] + } 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 + 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-type>> [ "content-type" pick set-at ] when* + over post-data>> [ + [ 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" ; + +M: byte-array >post-data "application/octet-stream" ; + +M: xml >post-data xml>string "text/xml" ; + +M: assoc >post-data assoc>query "application/x-www-form-urlencoded" ; + +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* ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index cf8a35f141..a6d8948790 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/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>> length number>string "CONTENT_LENGTH" set + request get post-data>> raw>> + [ "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 [ - 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 ; diff --git a/extra/http/server/dispatchers/dispatchers.factor b/extra/http/server/dispatchers/dispatchers.factor index 36eb447fc3..2da2695992 100644 --- a/extra/http/server/dispatchers/dispatchers.factor +++ b/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 -http http.server http.server.responses ; +USING: kernel namespaces sequences assocs accessors splitting +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 ; : ( -- 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 ) diff --git a/extra/http/server/redirection/redirection-tests.factor b/extra/http/server/redirection/redirection-tests.factor index 0b88231855..04af89ec98 100644 --- a/extra/http/server/redirection/redirection-tests.factor +++ b/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" ] [ - relative-to-request url>string + relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/baz" ] [ - "baz" >>path relative-to-request url>string + "baz" >>path relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/baz?c=d" ] [ - "baz" >>path { { "c" "d" } } >>query relative-to-request url>string + "baz" >>path { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/bar?c=d" ] [ - { { "c" "d" } } >>query relative-to-request url>string + { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.apple.com:80/flip" ] [ - "/flip" >>path relative-to-request url>string + "/flip" >>path relative-to-request present ] unit-test [ "http://www.apple.com:80/flip?c=d" ] [ - "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string + "/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 diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor new file mode 100644 index 0000000000..c29912b8c7 --- /dev/null +++ b/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 diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 756a0de0ff..10d6070f7b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -40,7 +40,7 @@ main-responder global [ <404> or ] change-at : <500> ( error -- response ) 500 "Internal server error" - development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ; + swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) dup write-response diff --git a/extra/io/unix/launcher/parser/parser.factor b/extra/io/unix/launcher/parser/parser.factor index f3bb82343a..e5e83ab4e9 100755 --- a/extra/io/unix/launcher/parser/parser.factor +++ b/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 -memoize ; +USING: peg peg.parsers kernel sequences strings words ; 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 ) - "\\" token [ drop t ] satisfy 2seq [ second ] action ; +: 'escaped-char' ( -- parser ) + "\\" 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 diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index fffc97b4c6..4171c79a0a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/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 -jamshred.player jamshred.tunnel kernel math math.vectors opengl -opengl.gl opengl.glu sequences ; +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 ; 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 ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 078a23f5db..b7764894d1 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -88,7 +88,7 @@ jamshred-gadget H{ { T{ mouse-scroll } [ handle-mouse-scroll ] } } set-gestures -: jamshred-window ( -- ) - [ "Jamshred" open-window ] with-ui ; +: jamshred-window ( -- jamshred ) + [ dup "Jamshred" open-window ] with-ui ; MAIN: jamshred-window diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index d50a93a3d2..7a37646a6d 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -39,8 +39,11 @@ C: 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 :: 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 ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 8dc5125143..c40729e35b 100644 --- a/extra/jamshred/player/player.factor +++ b/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 ) - [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ] - [ (>>last-move) ] tri ; +: distance-to-move ( seconds-passed player -- distance ) + speed>> * ; -DEFER: (move-player) +: bounce ( d-left player -- d-left' player ) + { + [ dup nearest-segment>> bounce-off-wall ] + [ sounds>> bang ] + [ 3/4 swap multiply-player-speed ] + [ ] + } cleave ; -: ?bounce ( distance-remaining player -- ) +:: (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-on-heading ( d-left player distance heading -- d-left' player ) + [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-toward-wall ( d-left player d-to-wall -- d-left' player ) + over [ forward>> ] keep distance-to-heading-segment-area min + over forward>> move-player-on-heading ; + +: ?move-player-freely ( d-left player -- d-left' player ) over 0 > [ - { - [ dup nearest-segment>> bounce ] - [ sounds>> bang ] - [ 3/4 swap multiply-player-speed ] - [ (move-player) ] - } cleave - ] [ - 2drop - ] if ; + dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2 + move-toward-wall ?move-player-freely + ] [ drop ] if + ] when ; -: move-player-distance ( distance-remaining player distance -- distance-remaining player ) - pick min tuck over go-forward [ - ] dip ; +: drag-heading ( player -- heading ) + [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; -: (move-player) ( distance-remaining player -- ) - over 0 <= [ - 2drop - ] [ - dup dup nearest-segment>> distance-to-collision - move-player-distance ?bounce - ] if ; +: 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>> - white swap set-segment-color ; + [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 903ff94739..722609851a 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/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 diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 5cf1e33e64..99c396bebd 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/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-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 : (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 : ( -- 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 ; @@ -97,6 +81,32 @@ C: 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 : wall-normal ( seg oint -- n ) location>> vector-to-centre normalize ; -: from ( seg loc -- radius d-f-c ) - dupd location>> distance-from-centre [ radius>> ] dip ; +: distant ( -- n ) 1000 ; -: distance-from-wall ( seg loc -- distance ) from - ; -: fraction-from-centre ( seg loc -- fraction ) from / ; -: fraction-from-wall ( seg loc -- fraction ) - fraction-from-centre 1 swap - ; +: max-real ( a b -- c ) + #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) + dup real? [ + over real? [ max ] [ nip ] if + ] [ + drop dup real? [ drop distant ] unless + ] if ; :: collision-coefficient ( v w r -- c ) - [let* | a [ v dup v. ] - b [ v w v. 2 * ] - c [ w dup v. r sq - ] | - c b a quadratic max ] ; + 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-real ] + ] if ; : sideways-heading ( oint segment -- v ) [ forward>> ] bi@ proj-perp ; @@ -126,18 +142,12 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; -: bounce-offset 0.1 ; inline - -: bounce-radius ( segment -- r ) - radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?) +: (distance-to-collision) ( oint segment -- distance ) + [ sideways-heading ] [ sideways-relative-location ] + [ nip radius>> ] 2tri collision-coefficient ; : collision-vector ( oint segment -- v ) - [ sideways-heading ] [ sideways-relative-location ] - [ bounce-radius ] 2tri - swap [ collision-coefficient ] dip forward>> n*v ; - -: distance-to-collision ( oint segment -- distance ) - collision-vector norm ; + dupd (distance-to-collision) swap forward>> n*v ; : bounce-forward ( segment oint -- ) [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; @@ -151,6 +161,6 @@ C: 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 ; diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 5e6b16dc2f..6bd6905804 100755 --- a/extra/json/reader/reader.factor +++ b/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 diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor deleted file mode 100644 index 6db82ed2c1..0000000000 --- a/extra/lazy-lists/lazy-lists.factor +++ /dev/null @@ -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? ; - -: ( 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 - -: lmap ( list quot -- result ) - over nil? [ 2drop nil ] [ ] 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 - -: ltake ( n list -- result ) - over zero? [ 2drop nil ] [ ] 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 - -: luntil ( list quot -- result ) - over nil? [ drop ] [ ] 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 - -: lwhile ( list quot -- result ) - over nil? [ drop ] [ ] 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 - -: lfilter ( list quot -- result ) - over nil? [ 2drop nil ] [ ] 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 - -: lappend ( list1 list2 -- result ) - over nil? [ nip ] [ ] 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 - -: lzip ( list1 list2 -- lazy-zip ) - over nil? over nil? or - [ 2drop nil ] [ ] 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 - -: seq>list ( index seq -- list ) - 2dup length >= [ - 2drop nil - ] [ - - ] 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 - -DEFER: lconcat - -: (lconcat) ( car cdr -- list ) - over nil? [ - nip lconcat - ] [ - - ] 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 - -: lcontents ( stream -- result ) - f f [ stream-read1 ] ; - -: llines ( stream -- result ) - f f [ stream-readln ] ; - -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 [ 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 diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 0312080907..c4090e1098 100644 --- a/extra/lisp/lisp-tests.factor +++ b/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 - "#t" [ t ] lisp-define + [ f ] "#f" lisp-define + [ t ] "#t" lisp-define - "+" "math" "+" define-primitve - "-" "math" "-" define-primitve + "+" "math" "+" define-primitive + "-" "math" "-" define-primitive + +! "list" [ >array ] lisp-define { 5 } [ [ 2 3 ] "+" 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 -] with-interactive-vocabs \ No newline at end of file + +! { { 1 2 3 4 5 } } [ +! "(list 1 2 3 4 5)" lisp-eval +! ] unit-test + +] with-interactive-vocabs diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 82a331f2ca..e865a2e3ed 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -1,48 +1,47 @@ ! 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 -vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry ; +namespaces combinators math locals locals.private accessors +vectors syntax lisp.parser assocs parser sequences.lib words +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-form compose ] reduce ; inline - -: convert-if ( s-exp -- quot ) - rest first3 [ convert-form ] tri@ '[ @ , , if ] ; +: convert-body ( cons -- quot ) + [ ] [ convert-form compose ] foldl ; inline -: convert-begin ( s-exp -- quot ) - rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; +: convert-begin ( cons -- quot ) + cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; -: convert-cond ( s-exp -- quot ) - rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] - { } map-as '[ , cond ] ; +: convert-cond ( cons -- quot ) + cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] + { } lmap-as '[ , cond ] ; -: convert-general-form ( s-exp -- quot ) - unclip convert-form swap convert-body swap '[ , @ funcall ] ; +: convert-general-form ( cons -- quot ) + uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ; ! words for convert-lambda > ] dip at swap or ] - [ dup s-exp? [ body>> localize-body ] when ] if - ] map ; - + [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ; + : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap - [ swap localize-body convert-form swap pop-locals ] dip swap ; + [ swap localize-body convert-form swap pop-locals ] dip swap ; -: split-lambda ( s-exp -- body vars ) - first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline +: split-lambda ( cons -- body-cons vars-seq ) + 3car -rot nip [ name>> ] lmap>array ; inline -: rest-lambda ( body vars -- quot ) +: rest-lambda ( body vars -- quot ) "&rest" swap [ index ] [ remove ] 2bi localize-lambda '[ , cut '[ @ , ] , compose ] ; @@ -51,46 +50,80 @@ DEFER: lookup-var localize-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 ) - second 1quotation ; +: convert-quoted ( cons -- quot ) + cdr 1quotation ; -: convert-list-form ( s-exp -- quot ) - dup first dup lisp-symbol? - [ name>> - { { "lambda" [ convert-lambda ] } - { "quote" [ convert-quoted ] } - { "if" [ convert-if ] } - { "begin" [ convert-begin ] } - { "cond" [ convert-cond ] } - [ drop convert-general-form ] - } case ] - [ drop convert-general-form ] if ; +: convert-unquoted ( cons -- quot ) + "unquote not valid outside of quasiquote!" throw ; -: convert-form ( lisp-form -- quot ) - { { [ dup s-exp? ] [ body>> convert-list-form ] } - { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } - [ 1quotation ] +: 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 ] } + { "unquote" [ convert-unquoted ] } + { "quasiquote" [ convert-quasiquoted ] } + { "begin" [ convert-begin ] } + { "cond" [ convert-cond ] } + [ drop convert-general-form ] + } case ; + +: 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 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 -- ) - swap lisp-env get set-at ; +: lisp-define ( quot name -- ) + 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 -- ) - swap lookup 1quotation '[ , compose call ] lisp-define ; \ No newline at end of file +: define-primitive ( name vocab word -- ) + 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 ; diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 98a6d2a6ba..4aa8154690 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/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 @@ -9,38 +9,60 @@ IN: lisp.parser.tests ] unit-test { -42 } [ - "-42" "atom" \ lisp-expr rule parse parse-result-ast + "-42" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { 37/52 } [ - "37/52" "atom" \ lisp-expr rule parse parse-result-ast + "37/52" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { 123.98 } [ - "123.98" "atom" \ lisp-expr rule parse parse-result-ast + "123.98" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "" } [ - "\"\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "aoeu" } [ - "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "aoeu\"de" } [ - "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { T{ lisp-symbol f "foobar" } } [ - "foobar" "atom" \ lisp-expr rule parse parse-result-ast + "foobar" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { T{ lisp-symbol f "+" } } [ - "+" "atom" \ lisp-expr rule parse parse-result-ast + "+" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test -{ T{ s-exp f - V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [ - "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast +{ +nil+ } [ + "()" 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 \ No newline at end of file diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index cf5ff56331..1e37193d3a 100644 --- a/extra/lisp/parser/parser.factor +++ b/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 -combinators.lib math ; +USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings +combinators.lib math fry accessors lists ; IN: lisp.parser TUPLE: lisp-symbol name ; C: lisp-symbol -TUPLE: s-exp body ; -C: 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 ]] @@ -36,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]] atom = number | identifier | string -list-item = _ (atom|s-expression) _ => [[ second ]] -s-expression = LPAREN (list-item)* RPAREN => [[ second ]] +list-item = _ ( atom | s-expression ) _ => [[ second ]] +s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]] ;EBNF \ No newline at end of file diff --git a/extra/lists/authors.txt b/extra/lists/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/lists/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/lazy-lists/authors.txt b/extra/lists/lazy/authors.txt similarity index 100% rename from extra/lazy-lists/authors.txt rename to extra/lists/lazy/authors.txt diff --git a/extra/lazy-lists/examples/authors.txt b/extra/lists/lazy/examples/authors.txt similarity index 100% rename from extra/lazy-lists/examples/authors.txt rename to extra/lists/lazy/examples/authors.txt diff --git a/extra/lazy-lists/examples/examples-tests.factor b/extra/lists/lazy/examples/examples-tests.factor similarity index 100% rename from extra/lazy-lists/examples/examples-tests.factor rename to extra/lists/lazy/examples/examples-tests.factor diff --git a/extra/lazy-lists/examples/examples.factor b/extra/lists/lazy/examples/examples.factor similarity index 75% rename from extra/lazy-lists/examples/examples.factor rename to extra/lists/lazy/examples/examples.factor index 844ae31085..f85344651d 100644 --- a/extra/lazy-lists/examples/examples.factor +++ b/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 ; -IN: lazy-lists.examples +USING: lists.lazy math kernel sequences quotations ; +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 ; diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lists/lazy/lazy-docs.factor similarity index 76% rename from extra/lazy-lists/lazy-lists-docs.factor rename to extra/lists/lazy/lazy-docs.factor index b240b3fbc2..6a9359027d 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/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 ; -IN: lazy-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 { "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." } ; +USING: help.markup help.syntax sequences strings lists ; +IN: lists.lazy 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: { $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 -{ $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 } ; +{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words -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" } { "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 +HELP: lazy-map { $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 } " 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" } } @@ -147,6 +85,8 @@ HELP: >list { $values { "object" "an object" } { "list" "a 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" } } @@ -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 } ; - diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lists/lazy/lazy-tests.factor similarity index 83% rename from extra/lazy-lists/lazy-lists-tests.factor rename to extra/lists/lazy/lazy-tests.factor index 302299b452..5749f94364 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/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 ; -IN: lazy-lists.tests +USING: lists lists.lazy tools.test kernel math io sequences ; +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 diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor new file mode 100644 index 0000000000..6beb6e402d --- /dev/null +++ b/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? ; + +: ( 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 ( list quot -- result ) + over nil? [ 2drop nil ] [ ] 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 + +: ltake ( n list -- result ) + over zero? [ 2drop nil ] [ ] 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 + +: luntil ( list quot -- result ) + over nil? [ drop ] [ ] 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 + +: lwhile ( list quot -- result ) + over nil? [ drop ] [ ] 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 + +: lfilter ( list quot -- result ) + over nil? [ 2drop nil ] [ ] 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 + +: lappend ( list1 list2 -- result ) + over nil? [ nip ] [ ] 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 + +: lzip ( list1 list2 -- lazy-zip ) + over nil? over nil? or + [ 2drop nil ] [ ] 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 + +: seq>list ( index seq -- list ) + 2dup length >= [ + 2drop nil + ] [ + + ] 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 + +DEFER: lconcat + +: (lconcat) ( car cdr -- list ) + over nil? [ + nip lconcat + ] [ + + ] 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 + +: lcontents ( stream -- result ) + f f [ stream-read1 ] ; + +: llines ( stream -- result ) + f f [ stream-readln ] ; + +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 [ >>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 diff --git a/extra/lazy-lists/old-doc.html b/extra/lists/lazy/old-doc.html similarity index 100% rename from extra/lazy-lists/old-doc.html rename to extra/lists/lazy/old-doc.html diff --git a/extra/lazy-lists/summary.txt b/extra/lists/lazy/summary.txt similarity index 100% rename from extra/lazy-lists/summary.txt rename to extra/lists/lazy/summary.txt diff --git a/extra/lazy-lists/tags.txt b/extra/lists/lazy/tags.txt similarity index 100% rename from extra/lazy-lists/tags.txt rename to extra/lists/lazy/tags.txt diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor new file mode 100644 index 0000000000..15faf8d002 --- /dev/null +++ b/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." } ; + diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor new file mode 100644 index 0000000000..cdc51b76e8 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor new file mode 100644 index 0000000000..13d77f757a --- /dev/null +++ b/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 ) + nil [ swap cons ] reduce ; + +: same? ( obj1 obj2 -- ? ) + [ class ] bi@ = ; + +: seq>cons ( seq -- cons ) + [ ] 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 \ No newline at end of file diff --git a/extra/lists/summary.txt b/extra/lists/summary.txt new file mode 100644 index 0000000000..60a18867ab --- /dev/null +++ b/extra/lists/summary.txt @@ -0,0 +1 @@ +Implementation of lisp-style linked lists diff --git a/extra/lists/tags.txt b/extra/lists/tags.txt new file mode 100644 index 0000000000..e44334b2b5 --- /dev/null +++ b/extra/lists/tags.txt @@ -0,0 +1,3 @@ +cons +lists +sequences diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor index 9244fa62e2..041cb8dc3a 100644 --- a/extra/math/erato/erato-tests.factor +++ b/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 diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 40de92e3b1..b9d997c038 100644 --- a/extra/math/erato/erato.factor +++ b/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 diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index 2f70ab24b4..aba7e90bc9 100644 --- a/extra/math/primes/factors/factors.factor +++ b/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 [ 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 ; diff --git a/extra/math/primes/primes-tests.factor b/extra/math/primes/primes-tests.factor index b1bcf79a49..186acc9b11 100644 --- a/extra/math/primes/primes-tests.factor +++ b/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 diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index 2eeaca6c92..59aebbf0dd 100644 --- a/extra/math/primes/primes.factor +++ b/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 diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor index 52cdc47ac6..d0014b5abe 100644 --- a/extra/monads/monads-tests.factor +++ b/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 diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor index 0f4138c985..c1ab4400ba 100644 --- a/extra/monads/monads.factor +++ b/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 diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 9d335896be..591915b317 100644 --- a/extra/morse/morse.factor +++ b/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 r cache-key* refcounts get + [ [ 0 ] unless* ] r> compose change-at ; + +TUPLE: cache-entry tex dims ; +C: cache-entry + +: make-entry ( gadget -- entry ) + dup render* + [ swap cache-key* textures get set-at ] keep ; + +: get-entry ( gadget -- {texture,dims} ) + dup cache-key* textures get at + [ nip ] [ make-entry ] if* ; + +: get-dims ( gadget -- dims ) + get-entry dims>> ; + +: get-texture ( gadget -- texture ) + get-entry tex>> ; + +: release-texture ( gadget -- ) + cache-key* textures get delete-at* + [ tex>> delete-texture ] [ drop ] if ; + +M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; + +M: texture-gadget ungraft* ( gadget -- ) + dup [ 1- ] refcount-change + dup cache-key* refcounts get at + zero? [ release-texture ] [ drop ] if ; : 2^-ceil ( x -- y ) dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable @@ -13,31 +60,29 @@ TUPLE: texture-gadget bytes format dim tex ; : 2^-bounds ( dim -- dim' ) [ 2^-ceil ] map ; foldable flushable -: ( bytes format dim -- gadget ) - texture-gadget construct-gadget - swap >>dim - swap >>format - swap >>bytes ; - -GENERIC: render* ( texture-gadget -- ) - -M:: texture-gadget render* ( gadget -- ) +:: (render-bytes) ( dims bytes format texture -- ) GL_ENABLE_BIT [ GL_TEXTURE_2D glEnable - GL_TEXTURE_2D gadget tex>> glBindTexture + GL_TEXTURE_2D texture glBindTexture GL_TEXTURE_2D 0 GL_RGBA - gadget dim>> 2^-bounds first2 + dims 2^-bounds first2 0 - gadget format>> + format GL_UNSIGNED_BYTE - gadget bytes>> + bytes glTexImage2D init-texture GL_TEXTURE_2D 0 glBindTexture ] do-attribs ; +: render-bytes ( dims bytes format -- texture ) + gen-texture [ (render-bytes) ] keep ; + +: render-bytes* ( dims bytes format -- texture dims ) + pick >r render-bytes r> ; + :: four-corners ( dim -- ) [let* | w [ dim first ] h [ dim second ] @@ -56,19 +101,12 @@ M: texture-gadget draw-gadget* ( gadget -- ) white gl-color 1.0 -1.0 glPixelZoom GL_TEXTURE_2D glEnable - GL_TEXTURE_2D over tex>> glBindTexture + GL_TEXTURE_2D over get-texture glBindTexture GL_QUADS [ - dim>> four-corners + get-dims four-corners ] do-state GL_TEXTURE_2D 0 glBindTexture ] do-attribs ] with-translation ; -M: texture-gadget graft* ( gadget -- ) - gen-texture >>tex [ render* ] - [ f >>bytes drop ] bi ; - -M: texture-gadget ungraft* ( gadget -- ) - tex>> delete-texture ; - -M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ; +M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ; diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index d1b536d9bc..f6c1ee498d 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -9,8 +9,8 @@ arrays pango pango.fonts ; IN: pango.cairo << "pangocairo" { -! { [ os winnt? ] [ "libpangocairo-1.dll" ] } -! { [ os macosx? ] [ "libpangocairo.dylib" ] } + { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] } + { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] } { [ os unix? ] [ "libpangocairo-1.0.so" ] } } cond "cdecl" add-library >> @@ -93,43 +93,24 @@ pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width ! Higher level words and combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: destructors accessors namespaces kernel cairo ; - -TUPLE: pango-layout alien ; -C: pango-layout -M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; - -: layout ( -- pango-layout ) pango-layout get ; +USING: pango.layouts +destructors accessors namespaces kernel cairo ; : (with-pango) ( layout quot -- ) >r alien>> pango-layout r> with-variable ; inline -: with-pango ( quot -- ) - cr pango_cairo_create_layout swap - [ (with-pango) ] curry with-disposal ; inline - -: pango-layout-get-pixel-size ( layout -- width height ) - 0 0 [ pango_layout_get_pixel_size ] 2keep - [ *int ] bi@ ; +: with-pango-cairo ( quot -- ) + cr pango_cairo_create_layout swap with-layout ; MEMO: dummy-cairo ( -- cr ) CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ; : dummy-pango ( quot -- ) - >r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline + >r dummy-cairo cairo r> [ with-pango-cairo ] curry with-variable ; inline : layout-size ( quot -- dim ) [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline -: layout-font ( str -- ) - pango_font_description_from_string - dup zero? [ "pango: not a valid font." throw ] when - layout over pango_layout_set_font_description - pango_font_description_free ; - -: layout-text ( str -- ) - layout swap -1 pango_layout_set_text ; - : show-layout ( -- ) cr layout pango_cairo_show_layout ; diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 4c46b4e501..5fb579c1a1 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -1,64 +1,27 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: pango.cairo cairo cairo.ffi -cairo.gadgets namespaces arrays -fry accessors ui.gadgets assocs -sequences shuffle opengl opengl.gadgets -alien.c-types kernel math ; +USING: pango.cairo pango.gadgets +cairo.gadgets arrays namespaces +fry accessors ui.gadgets +sequences opengl.gadgets +kernel pango.layouts ; + IN: pango.cairo.gadgets -SYMBOL: textures -SYMBOL: dims -SYMBOL: refcounts +TUPLE: pango-cairo-gadget < pango-gadget ; -: init-cache ( symbol -- ) - dup get [ drop ] [ H{ } clone swap set-global ] if ; +SINGLETON: pango-cairo-backend +pango-cairo-backend pango-backend set-global -textures init-cache -dims init-cache -refcounts init-cache +M: pango-cairo-backend construct-pango + pango-cairo-gadget construct-gadget ; -TUPLE: pango-gadget < cairo-gadget text font ; +: setup-layout ( gadget -- quot ) + [ font>> ] [ text>> ] bi + '[ , layout-font , layout-text ] ; -: cache-key ( gadget -- key ) - [ font>> ] [ text>> ] bi 2array ; - -: refcount-change ( gadget quot -- ) - >r cache-key refcounts get - [ [ 0 ] unless* ] r> compose change-at ; - -: ( font text -- gadget ) - pango-gadget construct-gadget - swap >>text - swap >>font ; - -: setup-layout ( {font,text} -- quot ) - first2 '[ , layout-font , layout-text ] ; - -M: pango-gadget quot>> ( gadget -- quot ) - cache-key setup-layout [ show-layout ] compose - [ with-pango ] curry ; - -M: pango-gadget dim>> ( gadget -- dim ) - cache-key dims get [ setup-layout layout-size ] cache ; - -M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; - -: release-texture ( gadget -- ) - cache-key textures get delete-at* [ delete-texture ] [ drop ] if ; - -M: pango-gadget ungraft* ( gadget -- ) - dup [ 1- ] refcount-change - dup cache-key refcounts get at - zero? [ release-texture ] [ drop ] if ; - -M: pango-gadget render* ( gadget -- ) - [ gen-texture ] [ cache-key textures get set-at ] bi - call-next-method ; - -M: pango-gadget tex>> ( gadget -- texture ) - dup cache-key textures get at - [ nip ] [ dup render* tex>> ] if* ; - -USE: ui.gadgets.panes -: hello "Sans 50" "hello" gadget. ; +M: pango-cairo-gadget render* ( gadget -- ) + setup-layout [ layout-size dup ] + [ + '[ [ @ show-layout ] with-pango-cairo ] + ] bi render-cairo render-bytes* ; diff --git a/extra/pango/ft2/ft2.factor b/extra/pango/ft2/ft2.factor new file mode 100644 index 0000000000..5ce59c7095 --- /dev/null +++ b/extra/pango/ft2/ft2.factor @@ -0,0 +1,56 @@ +USING: alien alien.c-types +math kernel byte-arrays freetype +opengl.gadgets accessors pango +ui.gadgets memoize +arrays sequences libc opengl.gl +system combinators alien.syntax +pango.layouts ; +IN: pango.ft2 + +<< "pangoft2" { + { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] } + { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] } + { [ os unix? ] [ "libpangoft2-1.0.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: pangoft2 + +FUNCTION: PangoFontMap* +pango_ft2_font_map_new ( ) ; + +FUNCTION: PangoContext* +pango_ft2_font_map_create_context ( PangoFT2FontMap* fontmap ) ; + +FUNCTION: void +pango_ft2_render_layout ( FT_Bitmap* bitmap, PangoLayout* layout, int x, int y ) ; + +: 4*-ceil ( n -- k*4 ) + 3 + 4 /i 4 * ; + +: ( width height -- ft-bitmap ) + swap dup + 2dup * 4*-ceil + "uchar" malloc-array + 256 + FT_PIXEL_MODE_GRAY + "FT_Bitmap" dup >r + { + set-FT_Bitmap-rows + set-FT_Bitmap-width + set-FT_Bitmap-pitch + set-FT_Bitmap-buffer + set-FT_Bitmap-num_grays + set-FT_Bitmap-pixel_mode + } set-slots r> ; + +: render-layout ( layout -- dims alien ) + [ + pango-layout-get-pixel-size + 2array dup 2^-bounds first2 dup + ] [ 0 0 pango_ft2_render_layout ] bi FT_Bitmap-buffer ; + +MEMO: ft2-context ( -- PangoContext* ) + pango_ft2_font_map_new pango_ft2_font_map_create_context ; + +: with-ft2-layout ( quot -- ) + ft2-context pango_layout_new swap with-layout ; inline diff --git a/extra/pango/ft2/gadgets/gadgets.factor b/extra/pango/ft2/gadgets/gadgets.factor new file mode 100644 index 0000000000..43ddc954ee --- /dev/null +++ b/extra/pango/ft2/gadgets/gadgets.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: pango.ft2 pango.gadgets opengl.gadgets +accessors kernel opengl.gl libc +sequences namespaces ui.gadgets pango.layouts ; +IN: pango.ft2.gadgets + +TUPLE: pango-ft2-gadget < pango-gadget ; + +SINGLETON: pango-ft2-backend +pango-ft2-backend pango-backend set-global + +M: pango-ft2-backend construct-pango + pango-ft2-gadget construct-gadget ; + +M: pango-ft2-gadget render* + [ + [ text>> layout-text ] [ font>> layout-font ] bi + layout render-layout + ] with-ft2-layout [ GL_ALPHA render-bytes* ] keep free ; diff --git a/extra/pango/gadgets/gadgets.factor b/extra/pango/gadgets/gadgets.factor new file mode 100644 index 0000000000..f9442a4613 --- /dev/null +++ b/extra/pango/gadgets/gadgets.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: opengl.gadgets kernel +arrays +accessors ; + +IN: pango.gadgets + +TUPLE: pango-gadget < texture-gadget text font ; + +M: pango-gadget cache-key* [ font>> ] [ text>> ] bi 2array ; + +SYMBOL: pango-backend +HOOK: construct-pango pango-backend ( -- gadget ) + +: ( font text -- gadget ) + construct-pango + swap >>text + swap >>font ; diff --git a/extra/pango/layouts/layouts.factor b/extra/pango/layouts/layouts.factor new file mode 100644 index 0000000000..71317ce552 --- /dev/null +++ b/extra/pango/layouts/layouts.factor @@ -0,0 +1,30 @@ +USING: alien alien.c-types +math +destructors accessors namespaces +pango kernel ; +IN: pango.layouts + +: pango-layout-get-pixel-size ( layout -- width height ) + 0 0 [ pango_layout_get_pixel_size ] 2keep + [ *int ] bi@ ; + +TUPLE: pango-layout alien ; +C: pango-layout +M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; + +: layout ( -- pango-layout ) pango-layout get ; + +: (with-layout) ( pango-layout quot -- ) + >r alien>> pango-layout r> with-variable ; inline + +: with-layout ( layout quot -- ) + >r r> [ (with-layout) ] curry with-disposal ; inline + +: layout-font ( str -- ) + pango_font_description_from_string + dup zero? [ "pango: not a valid font." throw ] when + layout over pango_layout_set_font_description + pango_font_description_free ; + +: layout-text ( str -- ) + layout swap -1 pango_layout_set_text ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index 3549d9abb4..be5c257cb0 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -9,8 +9,8 @@ IN: pango ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! << "pango" { -! { [ os winnt? ] [ "libpango-1.dll" ] } -! { [ os macosx? ] [ "libpango.dylib" ] } + { [ os winnt? ] [ "libpango-1.0-0.dll" ] } + { [ os macosx? ] [ "libpango-1.0.0.dylib" ] } { [ os unix? ] [ "libpango-1.0.so" ] } } cond "cdecl" add-library >> @@ -18,6 +18,9 @@ LIBRARY: pango : PANGO_SCALE 1024 ; +FUNCTION: PangoLayout* +pango_layout_new ( PangoContext* context ) ; + FUNCTION: void pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; diff --git a/extra/parser-combinators/parser-combinators-docs.factor b/extra/parser-combinators/parser-combinators-docs.factor index 41171ce822..c08243d17d 100755 --- a/extra/parser-combinators/parser-combinators-docs.factor +++ b/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" } } ; diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 2dd3fd911c..70698daa0b 100755 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/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 diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 9537a0c88c..2414c1ced3 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/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 - ] lmap-with - ] lmap-with lconcat ; + ] lazy-map-with + ] 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 - ] lmap-with ; + ] lazy-map-with ; TUPLE: some-parser p1 ; diff --git a/extra/parser-combinators/simple/simple-docs.factor b/extra/parser-combinators/simple/simple-docs.factor index 78b731f5b0..fdf32bddb1 100755 --- a/extra/parser-combinators/simple/simple-docs.factor +++ b/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 diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index 745442610c..f7a696ca35 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/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 diff --git a/extra/persistent-vectors/authors.txt b/extra/persistent-vectors/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/persistent-vectors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/persistent-vectors/persistent-vectors-docs.factor b/extra/persistent-vectors/persistent-vectors-docs.factor new file mode 100644 index 0000000000..dc9222cedb --- /dev/null +++ b/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" diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor new file mode 100644 index 0000000000..f871c95e16 --- /dev/null +++ b/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 diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor new file mode 100644 index 0000000000..f9f4b68933 --- /dev/null +++ b/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>> ; + +> ] 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 diff --git a/extra/persistent-vectors/summary.txt b/extra/persistent-vectors/summary.txt new file mode 100644 index 0000000000..19f3f66ca3 --- /dev/null +++ b/extra/persistent-vectors/summary.txt @@ -0,0 +1 @@ +Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop diff --git a/extra/persistent-vectors/tags.txt b/extra/persistent-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/persistent-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/present/present.factor b/extra/present/present.factor new file mode 100644 index 0000000000..1fae84184a --- /dev/null +++ b/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 "" ; diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index 93754b69d1..04686a8328 100644 --- a/extra/project-euler/007/007.factor +++ b/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 diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index 11af1960ed..4e54a18f19 100644 --- a/extra/project-euler/134/134.factor +++ b/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 diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 78ffaf5eeb..91dea0dd56 100755 --- a/extra/regexp/regexp.factor +++ b/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 ; diff --git a/extra/rss/authors.txt b/extra/rss/authors.txt deleted file mode 100755 index f990dd0ed2..0000000000 --- a/extra/rss/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor deleted file mode 100644 index 5183af5145..0000000000 --- a/extra/rss/rss.factor +++ /dev/null @@ -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 - -TUPLE: entry title link description pub-date ; - -C: 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/" - tag-named dup [ children>string try-parsing-timestamp ] when - ] - } cleave ; - -: 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 - ; - -: 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 ; - -: 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 ; - -: 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 ; - -: atom1.0 ( xml -- feed ) - [ "title" tag-named children>string ] - [ "link" tag-named "href" swap at ] - [ "entry" tags-named [ atom1.0-entry ] map ] - 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" [ - 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* ; diff --git a/extra/syndication/authors.txt b/extra/syndication/authors.txt new file mode 100755 index 0000000000..89b32cecee --- /dev/null +++ b/extra/syndication/authors.txt @@ -0,0 +1,3 @@ +Daniel Ehrenberg +Chris Double +Slava Pestov diff --git a/extra/rss/readme.txt b/extra/syndication/readme.txt similarity index 100% rename from extra/rss/readme.txt rename to extra/syndication/readme.txt diff --git a/extra/rss/summary.txt b/extra/syndication/summary.txt similarity index 100% rename from extra/rss/summary.txt rename to extra/syndication/summary.txt diff --git a/extra/rss/rss-tests.factor b/extra/syndication/syndication-tests.factor similarity index 63% rename from extra/rss/rss-tests.factor rename to extra/syndication/syndication-tests.factor index 0e6bb0b9c1..73541e7908 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/syndication/syndication-tests.factor @@ -1,6 +1,9 @@ -USING: rss io kernel io.files tools.test io.encodings.utf8 -calendar ; -IN: rss.tests +USING: syndication io kernel io.files tools.test io.encodings.utf8 +calendar urls ; +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
\n

[Update: The Atom draft is finished.]

\n
\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 diff --git a/extra/syndication/syndication.factor b/extra/syndication/syndication.factor new file mode 100644 index 0000000000..12beaf4cd7 --- /dev/null +++ b/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 new ; + +TUPLE: entry title url description date ; + +: set-entries ( feed entries -- feed ) + [ dup url>> ] dip + [ [ derive-url ] change-url ] with map + >>entries ; + +: ( -- 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/" + 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* ; diff --git a/extra/syndication/tags.txt b/extra/syndication/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/extra/syndication/tags.txt @@ -0,0 +1 @@ +web diff --git a/extra/rss/atom.xml b/extra/syndication/test/atom.xml similarity index 100% rename from extra/rss/atom.xml rename to extra/syndication/test/atom.xml diff --git a/extra/rss/rss1.xml b/extra/syndication/test/rss1.xml similarity index 100% rename from extra/rss/rss1.xml rename to extra/syndication/test/rss1.xml diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor index 644a9be1b5..90df619ff7 100644 --- a/extra/tetris/game/game.factor +++ b/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? ; diff --git a/extra/tetris/piece/piece.factor b/extra/tetris/piece/piece.factor index 981b509bfa..55215dbf6a 100644 --- a/extra/tetris/piece/piece.factor +++ b/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 diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index 080352449b..a718989476 100644 --- a/extra/urls/urls-tests.factor +++ b/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 diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 5c89205d5b..bb4d17e1f5 100644 --- a/extra/urls/urls.factor +++ b/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 +hex 2 CHAR: 0 pad-left % ] each ; +PRIVATE> + : url-encode ( str -- str ) [ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; += [ 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 ; + + : query>assoc ( query -- assoc ) dup [ "&" split H{ } clone [ @@ -77,11 +89,7 @@ IN: urls : assoc>query ( hash -- str ) [ - { - { [ dup number? ] [ number>string 1array ] } - { [ dup string? ] [ 1array ] } - { [ dup sequence? ] [ ] } - } cond + dup array? [ [ present ] map ] [ present 1array ] if ] assoc-map [ [ @@ -108,6 +116,8 @@ TUPLE: url protocol username password host port path query anchor ; ] when ] bi* ; +>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* ; +> 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 ; diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 853af6e845..44899cba31 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/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" add-responder "planet" add-responder "wiki" add-responder + "wee-url" add-responder "user-admin" add-responder users-in-db >>users @@ -53,8 +58,7 @@ TUPLE: factor-website < dispatcher ; allow-edit-profile { factor-website "page" } >>template - - + test-db ; : init-factor-website ( -- ) diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 9f35d83fd8..ea69c7bf7d 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -2,7 +2,9 @@ - + + Paste: + Paste: @@ -28,7 +30,7 @@
- Delete Annotation + Delete Annotation @@ -36,13 +38,13 @@

New Annotation

- + - + diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index 5ef44ad6ce..47f7666b22 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -2,7 +2,7 @@ - + Pastebin @@ -14,10 +14,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 69650b4d73..9e477d6156 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs sorting sequences kernel accessors hashtables sequences.lib db.types db.tuples db combinators -calendar calendar.format math.parser rss urls xml.writer +calendar calendar.format math.parser syndication urls xml.writer xmode.catalog validators html.components html.templates.chloe @@ -14,7 +14,7 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate -furnace.rss ; +furnace.syndication ; IN: webapps.pastebin TUPLE: pastebin < dispatcher ; @@ -35,6 +35,14 @@ entity f { "contents" "CONTENTS" TEXT +not-null+ } } define-persistent +GENERIC: entity-url ( entity -- url ) + +M: entity feed-entry-title summary>> ; + +M: entity feed-entry-date date>> ; + +M: entity feed-entry-url entity-url ; + TUPLE: paste < entity annotations ; \ paste "PASTES" { } define-persistent @@ -58,39 +66,31 @@ annotation "ANNOTATIONS" swap >>id swap >>parent ; -: fetch-annotations ( paste -- paste ) - dup annotations>> [ - dup id>> f select-tuples >>annotations - ] unless ; - : paste ( id -- paste ) - select-tuple fetch-annotations ; + [ select-tuple ] + [ f select-tuples ] + bi >>annotations ; ! ! ! ! LINKS, ETC ! ! ! -: pastebin-link ( -- url ) +: pastebin-url ( -- url ) URL" $pastebin/list" ; -GENERIC: entity-link ( entity -- url ) +: paste-url ( id -- url ) + "$pastebin/paste" >url swap "id" set-query-param ; -: paste-link ( id -- url ) - - "$pastebin/paste" >>path - swap "id" set-query-param ; +M: paste entity-url + id>> paste-url ; -M: paste entity-link - id>> paste-link ; - -: annotation-link ( parent id -- url ) - - "$pastebin/paste" >>path +: annotation-url ( parent id -- url ) + "$pastebin/paste" >url swap number>string >>anchor swap "id" set-query-param ; -M: annotation entity-link - [ parent>> ] [ id>> ] bi annotation-link ; +M: annotation entity-url + [ parent>> ] [ id>> ] bi annotation-url ; ! ! ! ! PASTE LIST @@ -101,24 +101,11 @@ M: annotation entity-link [ pastes "pastes" set-value ] >>init { pastebin "pastebin" } >>template ; -: pastebin-feed-entries ( seq -- entries ) - 20 short head [ - entry new - swap - [ summary>> >>title ] - [ date>> >>pub-date ] - [ entity-link adjust-url relative-to-request >>link ] - tri - ] map ; - -: pastebin-feed ( -- feed ) - feed new - "Factor Pastebin" >>title - pastebin-link >>link - pastes pastebin-feed-entries >>entries ; - : ( -- action ) - [ pastebin-feed ] >>feed ; + + [ pastebin-url ] >>url + [ "Factor Pastebin" ] >>title + [ pastes ] >>entries ; ! ! ! ! PASTES @@ -132,7 +119,7 @@ M: annotation entity-link "id" value "new-annotation" [ - "id" set-value + "parent" set-value mode-names "modes" set-value "factor" "mode" set-value ] nest-values @@ -140,21 +127,12 @@ M: annotation entity-link { pastebin "paste" } >>template ; -: paste-feed-entries ( paste -- entries ) - fetch-annotations annotations>> pastebin-feed-entries ; - -: paste-feed ( paste -- feed ) - feed new - swap - [ "Paste " swap id>> number>string append >>title ] - [ entity-link adjust-url relative-to-request >>link ] - [ paste-feed-entries >>entries ] - tri ; - : ( -- action ) [ validate-integer-id ] >>init - [ "id" value paste paste-feed ] >>feed ; + [ "id" value paste-url ] >>url + [ "Paste " "id" value number>string append ] >>title + [ "id" value f select-tuples ] >>entries ; : validate-entity ( -- ) { @@ -186,7 +164,7 @@ M: annotation entity-link f [ deposit-entity-slots ] [ insert-tuple ] - [ id>> paste-link ] + [ id>> paste-url ] tri ] >>submit ; @@ -207,20 +185,15 @@ M: annotation entity-link : ( -- action ) [ - { { "id" [ v-integer ] } } validate-params - "id" value paste-link - ] >>display - - [ - { { "id" [ v-integer ] } } validate-params + { { "parent" [ v-integer ] } } validate-params validate-entity ] >>validate [ - "id" value f + "parent" value f [ deposit-entity-slots ] [ insert-tuple ] - [ entity-link ] + [ entity-url ] tri ] >>submit ; @@ -231,7 +204,7 @@ M: annotation entity-link [ f "id" value select-tuple [ delete-tuples ] - [ parent>> paste-link ] + [ parent>> paste-url ] bi ] >>submit ; @@ -246,9 +219,13 @@ can-delete-pastes? define-capability "paste" add-responder "paste.atom" add-responder "new-paste" add-responder - { can-delete-pastes? } "delete-paste" add-responder + + "delete pastes" >>description + { can-delete-pastes? } >>capabilities "delete-paste" add-responder "new-annotation" add-responder - { can-delete-pastes? } "delete-annotation" add-responder + + "delete annotations" >>description + { can-delete-pastes? } >>capabilities "delete-annotation" add-responder { pastebin "pastebin-common" } >>template ; diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 26a3e6f206..192592489e 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -14,9 +14,9 @@ -

+

Add Blog | Update -

+
diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml deleted file mode 100644 index 70274d67d9..0000000000 --- a/extra/webapps/planet/entry-summary.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - -

-
- Read More... -

- - diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml deleted file mode 100644 index 01fda67316..0000000000 --- a/extra/webapps/planet/entry.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - -

- -

- -

- -

- -

- -

- - diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml index 8de7216b0e..661c2dc0f7 100644 --- a/extra/webapps/planet/mini-planet.xml +++ b/extra/webapps/planet/mini-planet.xml @@ -5,7 +5,7 @@

-
+
Read More...

diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index e92f88c2c2..34ee73da67 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -11,10 +11,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index c5fa5e25d4..5af96cd4f7 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -4,7 +4,7 @@ USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces sequences.lib db.types db.tuples db fry locals hashtables html.components -rss urls xml.writer +syndication urls xml.writer validators http.server http.server.dispatchers @@ -13,7 +13,7 @@ furnace.actions furnace.boilerplate furnace.auth.login furnace.auth -furnace.rss ; +furnace.syndication ; IN: webapps.planet TUPLE: planet-factor < dispatcher ; @@ -34,16 +34,15 @@ blog "BLOGS" { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ } } define-persistent -! TUPLE: posting < entry id ; -TUPLE: posting id title link description pub-date ; +TUPLE: posting < entry id ; posting "POSTINGS" { { "id" "ID" INTEGER +db-assigned-id+ } { "title" "TITLE" { VARCHAR 256 } +not-null+ } - { "link" "LINK" { VARCHAR 256 } +not-null+ } + { "url" "LINK" { VARCHAR 256 } +not-null+ } { "description" "DESCRIPTION" TEXT +not-null+ } - { "pub-date" "DATE" TIMESTAMP +not-null+ } + { "date" "DATE" TIMESTAMP +not-null+ } } define-persistent : init-blog-table blog ensure-table ; @@ -60,7 +59,7 @@ posting "POSTINGS" : postings ( -- seq ) posting new select-tuples - [ [ pub-date>> ] compare invert-comparison ] sort ; + [ [ date>> ] compare invert-comparison ] sort ; : ( -- action ) @@ -76,21 +75,18 @@ posting "POSTINGS" { planet-factor "planet" } >>template ; -: planet-feed ( -- feed ) - feed new - "Planet Factor" >>title - "http://planet.factorcode.org" >>link - postings >>entries ; - : ( -- action ) - [ planet-feed ] >>feed ; + + [ "Planet Factor" ] >>title + [ URL" $planet-factor" ] >>url + [ postings ] >>entries ; :: ( entry name -- entry' ) posting new name ": " entry title>> 3append >>title - entry link>> >>link + entry url>> >>url entry description>> >>description - entry pub-date>> >>pub-date ; + entry date>> >>date ; : fetch-feed ( url -- feed ) download-feed entries>> ; @@ -102,7 +98,7 @@ posting "POSTINGS" [ '[ , ] map ] 2map concat ; : sort-entries ( entries -- entries' ) - [ [ pub-date>> ] compare invert-comparison ] sort ; + [ [ date>> ] compare invert-comparison ] sort ; : update-cached-postings ( -- ) blogroll fetch-blogroll sort-entries 8 short head [ @@ -197,8 +193,11 @@ can-administer-planet-factor? define-capability : ( -- responder ) planet-factor new-dispatcher "list" add-main-responder - "feed.xml" add-responder - { can-administer-planet-factor? } "admin" add-responder + "feed.xml" add-responder + + "administer Planet Factor" >>description + { can-administer-planet-factor? } >>capabilities + "admin" add-responder { planet-factor "planet-common" } >>template ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 213c314d7a..96343bc5fa 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -11,7 +11,7 @@

- +

@@ -19,7 +19,7 @@

- +

diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 3600e2f874..1cecbc1094 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -122,4 +122,5 @@ todo "TODO" "delete" add-responder { todo-list "todo" } >>template - f ; + + "view your todo list" >>description ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 3dd0b9a7d1..e087fbfcfc 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -9,10 +9,10 @@ | Add Item - | Edit Profile + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index b8687274f0..19153e1354 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -18,18 +18,6 @@ IN: webapps.user-admin TUPLE: user-admin < dispatcher ; -: 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 ; - : ( -- action ) [ f select-tuples "users" set-value ] >>init @@ -95,7 +83,7 @@ TUPLE: user-admin < dispatcher ; [ from-object ] [ capabilities>> [ "true" swap word>string set-value ] each ] bi - capabilities get words>strings "capabilities" set-value + init-capabilities ] >>init { user-admin "edit-user" } >>template @@ -156,7 +144,9 @@ can-administer-users? define-capability "delete" add-responder { user-admin "user-admin" } >>template - { can-administer-users? } ; + + "administer users" >>description + { can-administer-users? } >>capabilities ; : make-admin ( username -- ) diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 93a701a696..9cb9ef0a0a 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -7,10 +7,10 @@ | Add User - | Edit Profile + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/wee-url/shorten.xml b/extra/webapps/wee-url/shorten.xml new file mode 100644 index 0000000000..8df7774fba --- /dev/null +++ b/extra/webapps/wee-url/shorten.xml @@ -0,0 +1,10 @@ + + + + + +

Shorten URL:

+ + + + diff --git a/extra/webapps/wee-url/show.xml b/extra/webapps/wee-url/show.xml new file mode 100644 index 0000000000..ba44629bb1 --- /dev/null +++ b/extra/webapps/wee-url/show.xml @@ -0,0 +1,11 @@ + + + + +

The URL:

+
+

has been shortened to:

+
+

enjoy!

+ + diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor new file mode 100644 index 0000000000..afdacf9add --- /dev/null +++ b/extra/webapps/wee-url/wee-url.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math.ranges sequences random accessors combinators.lib +kernel namespaces fry db.types db.tuples urls validators +html.components http http.server.dispatchers furnace +furnace.actions furnace.boilerplate ; +IN: webapps.wee-url + +TUPLE: wee-url < dispatcher ; + +TUPLE: short-url short url ; + +short-url "SHORT_URLS" { + { "short" "SHORT" TEXT +user-assigned-id+ } + { "url" "URL" TEXT +not-null+ } +} define-persistent + +: init-short-url-table ( -- ) + short-url ensure-table ; + +: letter-bank ( -- seq ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + CHAR: 1 CHAR: 0 [a,b] + 3append ; foldable + +: random-url ( -- string ) + 1 6 [a,b] random [ drop letter-bank random ] "" map-as ; + +: insert-short-url ( short-url -- short-url ) + '[ , dup random-url >>short insert-tuple ] 10 retry ; + +: shorten ( url -- short ) + short-url new swap >>url dup select-tuple + [ ] [ insert-short-url ] ?if short>> ; + +: short>url ( short -- url ) + "$wee-url/go/" prepend >url adjust-url ; + +: expand-url ( string -- url ) + short-url new swap >>short select-tuple url>> ; + +: ( -- action ) + + { wee-url "shorten" } >>template + [ { { "url" [ v-url ] } } validate-params ] >>validate + [ + "$wee-url/show/" "url" value shorten append >url + ] >>submit ; + +: ( -- action ) + + "short" >>rest + [ + { { "short" [ v-one-word ] } } validate-params + "short" value expand-url "url" set-value + "short" value short>url "short" set-value + ] >>init + { wee-url "show" } >>template ; + +: ( -- action ) + + "short" >>rest + [ { { "short" [ v-one-word ] } } validate-params ] >>init + [ "short" value expand-url ] >>display ; + +: ( -- wee-url ) + wee-url new-dispatcher + "" add-responder + "show" add-responder + "go" add-responder + + { wee-url "wee-url" } >>template ; diff --git a/extra/webapps/wee-url/wee-url.xml b/extra/webapps/wee-url/wee-url.xml new file mode 100644 index 0000000000..98d1095ed6 --- /dev/null +++ b/extra/webapps/wee-url/wee-url.xml @@ -0,0 +1,13 @@ + + + + + WeeURL! + +
Shorten URL
+ +

+ + + + diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 95fb0de2fe..5b3e9de2c4 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -7,7 +7,7 @@
  • - + on by diff --git a/extra/webapps/wiki/page-common.xml b/extra/webapps/wiki/page-common.xml index 1d4b507320..675cb8cd65 100644 --- a/extra/webapps/wiki/page-common.xml +++ b/extra/webapps/wiki/page-common.xml @@ -2,6 +2,10 @@ + + Revisions of + +
    diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index 61809802d9..6f22982f12 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -2,6 +2,10 @@ + + Edits by + + Edits by
      diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 67a5b91c93..4c6d1a5b5c 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -2,6 +2,10 @@ + + Recent Changes + +
      @@ -13,10 +17,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 6dcf89e208..611bba4c70 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order -html.components +html.components syndication http.server http.server.dispatchers furnace @@ -10,10 +10,26 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate +furnace.syndication validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki +: title-url ( title action -- url ) + "$wiki/" prepend >url swap "title" set-query-param ; + +: view-url ( title -- url ) "view" title-url ; + +: edit-url ( title -- url ) "edit" title-url ; + +: revisions-url ( title -- url ) "revisions" title-url ; + +: revision-url ( id -- url ) + "$wiki/revision" >url swap "id" set-query-param ; + +: user-edits-url ( author -- url ) + "$wiki/user-edits" >url swap "author" set-query-param ; + TUPLE: wiki < dispatcher ; TUPLE: article title revision ; @@ -39,6 +55,16 @@ revision "REVISIONS" { { "content" "CONTENT" TEXT +not-null+ } } define-persistent +M: revision feed-entry-title + [ title>> ] [ drop " by " ] [ author>> ] tri 3append ; + +M: revision feed-entry-date date>> ; + +M: revision feed-entry-url id>> revision-url ; + +: reverse-chronological-order ( seq -- sorted ) + [ [ date>> ] compare invert-comparison ] sort ; + : ( id -- revision ) revision new swap >>id ; @@ -47,18 +73,16 @@ revision "REVISIONS" { : validate-title ( -- ) { { "title" [ v-one-line ] } } validate-params ; +: validate-author ( -- ) + { { "author" [ v-username ] } } validate-params ; + : ( -- action ) - [ - - "$wiki/view" >>path - "Front Page" "title" set-query-param - - ] >>display ; + [ "Front Page" view-url ] >>display ; : ( -- action ) - "title" >>rest-param + "title" >>rest [ validate-title @@ -70,19 +94,17 @@ revision "REVISIONS" { revision>> select-tuple from-object { wiki "view" } ] [ - - "$wiki/edit" >>path - swap "title" set-query-param - + edit-url ] ?if ] >>display ; : ( -- action ) [ - { { "id" [ v-integer ] } } validate-params + validate-integer-id "id" value select-tuple from-object + "view?title=" relative-link-prefix set ] >>init { wiki "view" } >>template ; @@ -117,53 +139,53 @@ revision "REVISIONS" { now >>date logged-in-user get username>> >>author "content" value >>content - [ add-revision ] - [ - - "$wiki/view" >>path - swap title>> "title" set-query-param - - ] bi + [ add-revision ] [ title>> view-url ] bi ] >>submit ; +: list-revisions ( -- seq ) + f "title" value >>title select-tuples + reverse-chronological-order ; + : ( -- action ) [ validate-title - f "title" value >>title select-tuples - [ [ date>> ] compare invert-comparison ] sort - "revisions" set-value + list-revisions "revisions" set-value ] >>init - { wiki "revisions" } >>template ; +: ( -- action ) + + [ validate-title ] >>init + [ "Revisions of " "title" value append ] >>title + [ "title" value revisions-url ] >>url + [ list-revisions ] >>entries ; + : ( -- action ) - [ - { { "id" [ v-integer ] } } validate-params - ] >>validate - + [ validate-integer-id ] >>validate + [ "id" value select-tuple clone f >>id - [ add-revision ] - [ - - "$wiki/view" >>path - swap title>> "title" set-query-param - - ] bi + [ add-revision ] [ title>> view-url ] bi ] >>submit ; +: list-changes ( -- seq ) + "id" value select-tuples + reverse-chronological-order ; + : ( -- action ) - [ - f select-tuples - [ [ date>> ] compare invert-comparison ] sort - "changes" set-value - ] >>init + [ list-changes "changes" set-value ] >>init { wiki "changes" } >>template ; +: ( -- action ) + + [ URL" $wiki/changes" ] >>url + [ "All changes" ] >>title + [ list-changes ] >>entries ; + : ( -- action ) [ validate-title ] >>validate @@ -204,32 +226,53 @@ revision "REVISIONS" { { wiki "articles" } >>template ; +: list-user-edits ( -- seq ) + f "author" value >>author select-tuples + reverse-chronological-order ; + : ( -- action ) [ - { { "author" [ v-username ] } } validate-params - f "author" value >>author - select-tuples "user-edits" set-value + validate-author + list-user-edits "user-edits" set-value ] >>init - { wiki "user-edits" } >>template ; +: ( -- action ) + + [ validate-author ] >>init + [ "Edits by " "author" value append ] >>title + [ "author" value user-edits-url ] >>url + [ list-user-edits ] >>entries ; + +SYMBOL: can-delete-wiki-articles? + +can-delete-wiki-articles? define-capability + +: ( responder -- responder' ) + + { wiki "page-common" } >>template ; + : ( -- dispatcher ) wiki new-dispatcher - - "" add-responder - "view" add-responder - "revision" add-responder - "revisions" add-responder - "diff" add-responder - { } "edit" add-responder - - { wiki "page-common" } >>template - >>default + "" add-responder + "view" add-responder + "revision" add-responder + "revisions" add-responder + "revisions.atom" add-responder + "diff" add-responder + + "edit wiki articles" >>description + "edit" add-responder "rollback" add-responder "user-edits" add-responder "articles" add-responder "changes" add-responder - { } "delete" add-responder + "user-edits.atom" add-responder + "changes.atom" add-responder + + "delete wiki articles" >>description + { can-delete-wiki-articles? } >>capabilities + "delete" add-responder { wiki "wiki-common" } >>template ; diff --git a/extra/xml-rpc/example.factor b/extra/xml-rpc/example.factor index 0223dfde69..836a85d52d 100644 --- a/extra/xml-rpc/example.factor +++ b/extra/xml-rpc/example.factor @@ -22,6 +22,6 @@ USING: kernel hashtables xml-rpc xml calendar sequences put-http-response ; : test-rpc-arith - "add" { 1 2 } send-rpc xml>string - "text/xml" swap "http://localhost:8080/responder/rpc/" + "add" { 1 2 } send-rpc + "http://localhost:8080/responder/rpc/" http-post ; diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor index d41f66739c..4b96d13316 100755 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -158,8 +158,7 @@ TAG: array xml>item : post-rpc ( rpc url -- rpc ) ! This needs to do something in the event of an error - >r "text/xml" swap send-rpc xml>string r> http-post - 2nip string>xml receive-rpc ; + >r send-rpc r> http-post nip string>xml receive-rpc ; : invoke-method ( params method url -- ) >r swap r> post-rpc ; diff --git a/extra/yahoo/yahoo-docs.factor b/extra/yahoo/yahoo-docs.factor index b5603103e1..1758d62029 100644 --- a/extra/yahoo/yahoo-docs.factor +++ b/extra/yahoo/yahoo-docs.factor @@ -2,5 +2,5 @@ USING: help.syntax help.markup ; IN: yahoo HELP: search-yahoo -{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } } -{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ; +{ $values { "search" search } { "seq" "sequence of arrays of length 3" } } +{ $description "Uses Yahoo's REST API to search for the specified query, getting the number of answers specified. Returns a sequence of " { $link result } " instances." } ; diff --git a/misc/factor.el b/misc/factor.el index 9d90fb68f9..300c95c430 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -94,6 +94,10 @@ "SYMBOLS:" )) +(defun factor-indent-line () + "Indent current line as Factor code" + (indent-line-to (+ (current-indentation) 4))) + (defun factor-mode () "A mode for editing programs written in the Factor programming language." (interactive) @@ -107,6 +111,8 @@ (setq font-lock-defaults '(factor-font-lock-keywords nil nil nil nil)) (set-syntax-table factor-mode-syntax-table) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'factor-indent-line) (run-hooks 'factor-mode-hook)) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
Summary:
Author:
Mode:
Body:
Body:
Captcha: