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
{ $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 }
{ $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? } ;
{ $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 -- )" } } }
{ $syntax "\\ word" }
{ $values { "word" "a word" } }
{ $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." }
-{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } } ;
+{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } "If " { $snippet "foo" } " is a symbol, the following two lines are equivalent:" { $code "foo" "\\ foo" } } ;
HELP: DEFER:
{ $syntax "DEFER: word" }
"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:
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math opengl.gadgets kernel
byte-arrays cairo.ffi cairo io.backend
-opengl.gl arrays ;
+ui.gadgets accessors opengl.gl
+arrays ;
IN: cairo.gadgets
[ cairo_image_surface_create_for_data ] 3bi
r> with-cairo-from-surface ;
-: <cairo-gadget> ( dim quot -- )
- over 2^-bounds swap copy-cairo
- GL_BGRA rot <texture-gadget> ;
+TUPLE: cairo-gadget < texture-gadget quot ;
+
+: <cairo-gadget> ( dim quot -- gadget )
+ cairo-gadget construct-gadget
+ swap >>quot
+ swap >>dim ;
+
+M: cairo-gadget format>> drop GL_BGRA ;
+
+M: cairo-gadget render* ( gadget -- )
+ dup
+ [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi
+ >>bytes call-next-method ;
! maybe also texture>png
! : cairo>png ( gadget path -- )
init-request
{ } "action-1" get call-responder
] unit-test
+
+<action>
+ "a" >>rest
+ [ "a" param string>number sq ] >>display
+"action-2" set
+
+STRING: action-request-test-2
+GET http://foo/bar/123 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+ action-request-test-2 lf>crlf
+ [ read-request ] with-string-reader
+ init-request
+ { "5" } "action-2" get call-responder
+] unit-test
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors sequences kernel assocs combinators\r
validators http hashtables namespaces fry continuations locals\r
-io arrays math boxes\r
+io arrays math boxes splitting urls\r
xml.entities\r
http.server\r
http.server.responses\r
furnace\r
+furnace.flash\r
html.elements\r
html.components\r
+html.components\r
html.templates.chloe\r
html.templates.chloe.syntax ;\r
IN: furnace.actions\r
\r
SYMBOL: params\r
\r
-SYMBOL: rest-param\r
+SYMBOL: rest\r
\r
: render-validation-messages ( -- )\r
validation-messages get\r
\r
CHLOE: validation-messages drop render-validation-messages ;\r
\r
-TUPLE: action rest-param init display validate submit ;\r
+TUPLE: action rest init display validate submit ;\r
\r
: new-action ( class -- action )\r
new\r
: <action> ( -- action )\r
action new-action ;\r
\r
+: flashed-variables ( -- seq )\r
+ { validation-messages named-validation-messages } ;\r
+\r
: handle-get ( action -- response )\r
- blank-values\r
- [ init>> call ]\r
- [ display>> call ]\r
- bi ;\r
+ '[\r
+ ,\r
+ [ init>> call ]\r
+ [ drop flashed-variables restore-flash ]\r
+ [ display>> call ]\r
+ tri\r
+ ] with-exit-continuation ;\r
\r
: validation-failed ( -- * )\r
- request get method>> "POST" =\r
- [ action get display>> call ] [ <400> ] if exit-with ;\r
+ request get method>> "POST" = [ f ] [ <400> ] if exit-with ;\r
\r
-: handle-post ( action -- response )\r
- init-validation\r
- blank-values\r
- [ validate>> call ]\r
- [ submit>> call ] bi ;\r
+: (handle-post) ( action -- response )\r
+ [ validate>> call ] [ submit>> call ] bi ;\r
\r
-: handle-rest-param ( arg -- )\r
- dup length 1 > action get rest-param>> not or\r
- [ <404> exit-with ] [\r
- action get rest-param>> associate rest-param set\r
- ] if ;\r
+: param ( name -- value )\r
+ params get at ;\r
\r
-M: action call-responder* ( path action -- response )\r
- dup action set\r
- '[\r
- , dup empty? [ drop ] [ handle-rest-param ] if\r
+: revalidate-url-key "__u" ;\r
\r
- init-validation\r
- ,\r
- request get\r
- [ request-params rest-param get assoc-union params set ]\r
- [ method>> ] bi\r
- {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
- ] with-exit-continuation ;\r
+: check-url ( url -- ? )\r
+ request get url>>\r
+ [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;\r
\r
-: param ( name -- value )\r
- params get at ;\r
+: revalidate-url ( -- url/f )\r
+ revalidate-url-key param dup [ >url dup check-url swap and ] when ;\r
+\r
+: handle-post ( action -- response )\r
+ '[\r
+ form-nesting-key params get at " " split\r
+ [ , (handle-post) ]\r
+ [ swap '[ , , nest-values ] ] reduce\r
+ call\r
+ ] with-exit-continuation\r
+ [\r
+ revalidate-url\r
+ [ flashed-variables <flash-redirect> ] [ <403> ] if*\r
+ ] unless* ;\r
+\r
+: handle-rest ( path action -- assoc )\r
+ rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
+\r
+: init-action ( path action -- )\r
+ blank-values\r
+ init-validation\r
+ handle-rest\r
+ request get request-params assoc-union params set ;\r
+\r
+M: action call-responder* ( path action -- response )\r
+ [ init-action ] keep\r
+ request get method>> {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case ;\r
+\r
+M: action modify-form\r
+ drop request get url>> revalidate-url-key hidden-form-field ;\r
\r
: check-validation ( -- )\r
validation-failed? [ validation-failed ] when ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces sequences arrays kernel
+assocs assocs.lib hashtables math.parser urls combinators
+furnace http http.server http.server.filters furnace.sessions
+html.elements html.templates.chloe.syntax ;
+IN: furnace.asides
+
+TUPLE: asides < filter-responder ;
+
+C: <asides> asides
+
+: begin-aside* ( -- id )
+ request get
+ [ url>> ] [ post-data>> ] [ method>> ] tri 3array
+ asides sget set-at-unique
+ session-changed ;
+
+: end-aside-post ( url post-data -- response )
+ request [
+ clone
+ swap >>post-data
+ swap >>url
+ ] change
+ request get url>> path>> split-path
+ asides get responder>> call-responder ;
+
+ERROR: end-aside-in-get-error ;
+
+: end-aside* ( url id -- response )
+ request get method>> "POST" = [ end-aside-in-get-error ] unless
+ asides sget at [
+ first3 {
+ { "GET" [ drop <redirect> ] }
+ { "HEAD" [ drop <redirect> ] }
+ { "POST" [ end-aside-post ] }
+ } case
+ ] [ <redirect> ] ?if ;
+
+SYMBOL: aside-id
+
+: aside-id-key "__a" ;
+
+: begin-aside ( -- )
+ begin-aside* aside-id set ;
+
+: end-aside ( default -- response )
+ aside-id [ f ] change end-aside* ;
+
+M: asides call-responder*
+ dup asides set
+ aside-id-key request get request-params at aside-id set
+ call-next-method ;
+
+M: asides init-session*
+ H{ } clone asides sset
+ call-next-method ;
+
+M: asides link-attr ( tag -- )
+ drop
+ "aside" optional-attr {
+ { "none" [ aside-id off ] }
+ { "begin" [ begin-aside ] }
+ { "current" [ ] }
+ { f [ ] }
+ } case ;
+
+M: asides modify-query ( query responder -- query' )
+ drop
+ aside-id get [ aside-id-key associate assoc-union ] when* ;
+
+M: asides modify-form ( responder -- )
+ drop aside-id get aside-id-key hidden-form-field ;
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors quotations assocs kernel splitting\r
combinators sequences namespaces hashtables sets\r
-fry arrays threads qualified random validators\r
+fry arrays threads qualified random validators words\r
io\r
io.sockets\r
io.encodings.utf8\r
furnace.auth.providers\r
furnace.auth.providers.db\r
furnace.actions\r
-furnace.flows\r
+furnace.asides\r
+furnace.flash\r
furnace.sessions\r
furnace.boilerplate ;\r
QUALIFIED: smtp\r
IN: furnace.auth.login\r
\r
+: word>string ( word -- string )\r
+ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;\r
+\r
+: words>strings ( seq -- seq' )\r
+ [ word>string ] map ;\r
+\r
+: string>word ( string -- word )\r
+ ":" split1 swap lookup ;\r
+\r
+: strings>words ( seq -- seq' )\r
+ [ string>word ] map ;\r
+\r
TUPLE: login < dispatcher users checksum ;\r
\r
+TUPLE: protected < filter-responder description capabilities ;\r
+\r
: users ( -- provider )\r
login get users>> ;\r
\r
\r
! ! ! Login\r
: successful-login ( user -- response )\r
- username>> set-uid URL" $login" end-flow ;\r
+ username>> set-uid URL" $login" end-aside ;\r
\r
: login-failed ( -- * )\r
"invalid username or password" validation-error\r
\r
: <login-action> ( -- action )\r
<page-action>\r
+ [\r
+ protected fget [\r
+ [ description>> "description" set-value ]\r
+ [ capabilities>> words>strings "capabilities" set-value ] bi\r
+ ] when*\r
+ ] >>init\r
+\r
{ login "login" } >>template\r
\r
[\r
\r
drop\r
\r
- URL" $login" end-flow\r
+ URL" $login" end-aside\r
] >>submit ;\r
\r
! ! ! Password recovery\r
<action>\r
[\r
f set-uid\r
- URL" $login" end-flow\r
+ URL" $login" end-aside\r
] >>submit ;\r
\r
! ! ! Authentication logic\r
-\r
-TUPLE: protected < filter-responder capabilities ;\r
-\r
-C: <protected> protected\r
+: <protected> ( responder -- protected )\r
+ protected new\r
+ swap >>responder ;\r
\r
: show-login-page ( -- response )\r
- begin-flow\r
- URL" $login/login" <redirect> ;\r
+ begin-aside\r
+ URL" $login/login" { protected } <flash-redirect> ;\r
\r
: check-capabilities ( responder user -- ? )\r
[ capabilities>> ] bi@ subset? ;\r
\r
M: protected call-responder* ( path responder -- response )\r
+ dup protected set\r
uid dup [\r
users get-user 2dup check-capabilities [\r
[ logged-in-user set ] [ save-user-after ] bi\r
! ! ! Configuration\r
\r
: allow-edit-profile ( login -- login )\r
- <edit-profile-action> f <protected> <login-boilerplate>\r
+ <edit-profile-action> <protected>\r
+ "edit your profile" >>description\r
+ <login-boilerplate>\r
"edit-profile" add-responder ;\r
\r
: allow-registration ( login -- login )\r
<t:title>Login</t:title>
+ <t:if t:value="description">
+ <p>You must log in to <t:label t:name="description" />.</p>
+ </t:if>
+
+ <t:if t:value="capabilities">
+ <p>Your user must have the following capabilities:</p>
+ <ul>
+ <t:each t:name="capabilities">
+ <li><t:label t:name="value" /></li>
+ </t:each>
+ </ul>
+ </t:if>
+
<t:form t:action="login">
<table>
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs assocs.lib kernel sequences urls
+http http.server http.server.filters http.server.redirection
+furnace furnace.sessions ;
+IN: furnace.flash
+
+: flash-id-key "__f" ;
+
+TUPLE: flash-scopes < filter-responder ;
+
+C: <flash-scopes> flash-scopes
+
+SYMBOL: flash-scope
+
+: fget ( key -- value ) flash-scope get at ;
+
+M: flash-scopes call-responder*
+ flash-id-key
+ request get request-params at
+ flash-scopes sget at flash-scope set
+ call-next-method ;
+
+M: flash-scopes init-session*
+ H{ } clone flash-scopes sset
+ call-next-method ;
+
+: make-flash-scope ( seq -- id )
+ [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
+ session-changed ;
+
+: <flash-redirect> ( url seq -- response )
+ make-flash-scope
+ [ clone ] dip flash-id-key set-query-param
+ <redirect> ;
+
+: restore-flash ( seq -- )
+ [ flash-scope get key? ] filter [ [ fget ] keep set ] each ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces sequences arrays kernel
-assocs assocs.lib hashtables math.parser urls combinators
-furnace http http.server http.server.filters furnace.sessions
-html.elements html.templates.chloe.syntax ;
-IN: furnace.flows
-
-TUPLE: flows < filter-responder ;
-
-C: <flows> flows
-
-: begin-flow* ( -- id )
- request get
- [ url>> ] [ post-data>> ] [ method>> ] tri 3array
- flows sget set-at-unique
- session-changed ;
-
-: end-flow-post ( url post-data -- response )
- request [
- clone
- "POST" >>method
- swap >>post-data
- swap >>url
- ] change
- request get url>> path>> split-path
- flows get responder>> call-responder ;
-
-: end-flow* ( url id -- response )
- flows sget at [
- first3 {
- { "GET" [ drop <redirect> ] }
- { "HEAD" [ drop <redirect> ] }
- { "POST" [ end-flow-post ] }
- } case
- ] [ <redirect> ] ?if ;
-
-SYMBOL: flow-id
-
-: flow-id-key "factorflowid" ;
-
-: begin-flow ( -- )
- begin-flow* flow-id set ;
-
-: end-flow ( default -- response )
- flow-id get end-flow* ;
-
-M: flows call-responder*
- dup flows set
- flow-id-key request get request-params at flow-id set
- call-next-method ;
-
-M: flows init-session*
- H{ } clone flows sset
- call-next-method ;
-
-M: flows link-attr ( tag -- )
- drop
- "flow" optional-attr {
- { "none" [ flow-id off ] }
- { "begin" [ begin-flow ] }
- { "current" [ ] }
- { f [ ] }
- } case ;
-
-M: flows modify-query ( query responder -- query' )
- drop
- flow-id get [ flow-id-key associate assoc-union ] when* ;
-
-M: flows hidden-form-field ( responder -- )
- drop
- flow-id get [
- <input
- "hidden" =type
- flow-id-key =name
- =value
- input/>
- ] when* ;
IN: furnace.tests
USING: http.server.dispatchers http.server.responses
-http.server furnace tools.test kernel namespaces accessors ;
+http.server furnace tools.test kernel namespaces accessors
+io.streams.string ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
V{ } responder-nesting set
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
+
+[ "<input type='hidden' name='foo' value='&&&'/>" ]
+[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
+unit-test
! 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
http.server.responses
qualified ;
QUALIFIED-WITH: assocs a
+EXCLUDE: xml.utilities => children>string ;
IN: furnace
: nested-responders ( -- seq )
M: object modify-query drop ;
-: adjust-url ( url -- url' )
+GENERIC: adjust-url ( url -- url' )
+
+M: url adjust-url
clone
[ [ modify-query ] each-responder ] change-query
[ resolve-base-path ] change-path
relative-to-request ;
+M: string adjust-url ;
+
: <redirect> ( url -- response )
adjust-url request get method>> {
{ "GET" [ <temporary-redirect> ] }
{ "POST" [ <permanent-redirect> ] }
} case ;
-GENERIC: hidden-form-field ( responder -- )
+GENERIC: modify-form ( responder -- )
-M: object hidden-form-field drop ;
+M: object modify-form drop ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
- { "POST" [ post-data>> ] }
+ { "POST" [
+ post-data>>
+ dup content-type>> "application/x-www-form-urlencoded" =
+ [ content>> ] [ drop f ] if
+ ] }
} case ;
SYMBOL: exit-continuation
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
CHLOE: atom
- [ "title" required-attr ]
+ [ children>string ]
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ] tri
<url>
[ drop </a> ]
tri ;
+: hidden-form-field ( value name -- )
+ over [
+ <input
+ "hidden" =type
+ =name
+ present =value
+ input/>
+ ] [ 2drop ] if ;
+
+: form-nesting-key "__n" ;
+
+: form-magic ( tag -- )
+ [ modify-form ] each-responder
+ nested-values get " " join f like form-nesting-key hidden-form-field
+ "for" optional-attr [ hidden render ] when* ;
+
: form-start-tag ( tag -- )
[
[
<form
- "POST" =method
- [ link-attrs ]
- [ "action" required-attr resolve-base-path =action ]
- [ tag-attrs non-chloe-attrs-only print-attrs ]
- tri
+ "POST" =method
+ [ link-attrs ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ tri
form>
- ] [
- [ hidden-form-field ] each-responder
- "for" optional-attr [ hidden render ] when*
- ] bi
+ ]
+ [ form-magic ] bi
] with-scope ;
CHLOE: form
[ [ 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 ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel fry
-rss http.server.responses furnace.actions ;
-IN: furnace.rss
-
-: <feed-content> ( body -- response )
- feed>xml "application/atom+xml" <content> ;
-
-TUPLE: feed-action < action feed ;
-
-: <feed-action> ( -- feed )
- feed-action new-action
- dup '[ , feed>> call <feed-content> ] >>display ;
[ 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>> {
: put-session-cookie ( response -- response' )
session get id>> number>string <session-cookie> put-cookie ;
-M: sessions hidden-form-field ( responder -- )
- drop
- <input
- "hidden" =type
- session-id-key =name
- session get id>> 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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences fry sequences.lib
+combinators syndication
+http.server.responses http.server.redirection
+furnace furnace.actions ;
+IN: furnace.syndication
+
+GENERIC: feed-entry-title ( object -- string )
+
+GENERIC: feed-entry-date ( object -- timestamp )
+
+GENERIC: feed-entry-url ( object -- url )
+
+GENERIC: feed-entry-description ( object -- description )
+
+M: object feed-entry-description drop f ;
+
+GENERIC: >entry ( object -- entry )
+
+M: entry >entry ;
+
+M: object >entry
+ <entry>
+ swap {
+ [ feed-entry-title >>title ]
+ [ feed-entry-date >>date ]
+ [ feed-entry-url >>url ]
+ [ feed-entry-description >>description ]
+ } cleave ;
+
+: process-entries ( seq -- seq' )
+ 20 short head-slice [
+ >entry clone
+ [ adjust-url relative-to-request ] change-url
+ ] map ;
+
+: <feed-content> ( body -- response )
+ feed>xml "application/atom+xml" <content> ;
+
+TUPLE: feed-action < action title url entries ;
+
+: <feed-action> ( -- action )
+ feed-action new-action
+ dup '[
+ feed new
+ ,
+ [ title>> call >>title ]
+ [ url>> call adjust-url relative-to-request >>url ]
+ [ entries>> call process-entries >>entries ]
+ tri
+ <feed-content>
+ ] >>display ;
! 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
[ ] [ "jimmy" "red" set-value ] unit-test
-[ "123.5" ] [ 123.5 object>string ] unit-test
-
[ "jimmy" ] [
[
"red" label render
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
: deposit-slots ( destination names -- )
[ <mirror> ] dip deposit-values ;
-: with-each-index ( seq quot -- )
- '[
+: with-each-value ( name quot -- )
+ [ value ] dip '[
[
values [ clone ] change
- 1+ "index" set-value @
+ 1+ "index" set-value
+ "value" set-value
+ @
] with-scope
] each-index ; inline
-: with-each-value ( seq quot -- )
- '[ "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 [
<PRIVATE
: render-input ( value name type -- )
- <input =type =name object>string =value input/> ;
+ <input =type =name present =value input/> ;
PRIVATE>
SINGLETON: label
-M: label render* 2drop object>string escape-string write ;
+M: label render* 2drop present escape-string write ;
SINGLETON: hidden
: render-field ( value name size type -- )
<input
=type
- [ object>string =size ] when*
+ [ present =size ] when*
=name
- object>string =value
+ present =value
input/> ;
TUPLE: field size ;
M: textarea render*
<textarea
- [ rows>> [ object>string =rows ] when* ]
- [ cols>> [ object>string =cols ] when* ] bi
+ [ rows>> [ present =rows ] when* ]
+ [ cols>> [ present =cols ] when* ] bi
=name
textarea>
- object>string escape-string write
+ present escape-string write
</textarea> ;
! Choice
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
- object>string escape-string write
+ present escape-string write
</option> ;
: render-options ( options selected -- )
M: choice render*
<select
swap =name
- dup size>> [ object>string =size ] when*
+ dup size>> [ present =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
[ choices>> value ] [ multiple>> ] bi
GENERIC: link-title ( obj -- string )
GENERIC: link-href ( obj -- url )
+M: string link-title ;
+M: string link-href ;
+
+M: url link-title ;
+M: url link-href ;
+
SINGLETON: link
M: link render*
2drop
<a dup link-href =href a>
- link-title object>string escape-string write
+ link-title present escape-string write
</a> ;
! XMode code component
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
-urls math math.parser combinators calendar calendar.format ;
+urls math math.parser combinators present ;
IN: html.elements
dup def-for-html-word-<foo
def-for-html-word-foo/> ;
-: object>string ( object -- string )
- #! Should this be generic and in the core?
- {
- { [ dup real? ] [ number>string ] }
- { [ dup timestamp? ] [ timestamp>string ] }
- { [ dup url? ] [ url>string ] }
- { [ dup string? ] [ ] }
- { [ dup word? ] [ word-name ] }
- { [ dup not ] [ drop "" ] }
- } cond ;
-
: write-attr ( value name -- )
" " write-html
write-html
"='" write-html
- object>string escape-quoted-string write-html
+ present escape-quoted-string write-html
"'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ;
"test9" test-template call-template
] run-template
] unit-test
+
+[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
+
+[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
+ [
+ "test10" test-template call-template
+ ] run-template
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [
+ H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
+ [
+ "test11" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
+
+[ ] [
+ blank-values
+ { "a" "b" } "choices" set-value
+ "true" "b" set-value
+] unit-test
+
+[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
+ [
+ "test12" test-template call-template
+ ] run-template
+] unit-test
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
: (bind-tag) ( tag quot -- )
[
- [ "name" required-attr value ] keep
+ [ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
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
: expand-attrs ( tag -- tag )
dup [ tag? ] is? [
clone [
- [ "@" ?head [ value object>string ] when ] assoc-map
+ [ "@" ?head [ value present ] when ] assoc-map
] change-attrs
] when ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:bind t:name="a"><t:form t:action="foo"/></t:bind></t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <table>
+ <t:bind t:name="person">
+ <tr>
+ <td><t:label t:name="first-name"/></td>
+ <td><t:label t:name="last-name"/></td>
+ </tr>
+ </t:bind>
+ </table>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:each t:name="choices"><t:checkbox t:name="@value" t:label="@value" /></t:each></t:chloe>
SYMBOL: redirects
: redirect-url ( request url -- request )
- '[ , >url derive-url ensure-port ] change-url ;
+ '[ , >url ensure-port derive-url ensure-port ] change-url ;
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
: download ( url -- )
dup download-name download-to ;
-: <post-request> ( content-type content url -- request )
+: <post-request> ( post-data url -- request )
<request>
"POST" >>method
swap >url ensure-port >>url
- swap >>post-data
- swap >>post-data-type ;
+ swap >>post-data ;
-: http-post ( content-type content url -- response data )
+: http-post ( post-data url -- response data )
<post-request> http-request ;
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
;
[
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{ }
}
] [
] 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
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF8" } }
- cookies: V{ }
+ cookies: { }
content-type: "text/html"
content-charset: "UTF8"
}
[ ] [
[
<dispatcher>
+ <action> <protected>
<login>
<sessions>
"" add-responder
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
+
+USING: html.components html.elements xml xml.utilities validators
+furnace furnace.flash ;
+
+SYMBOL: a
+
+[ ] [
+ [
+ <dispatcher>
+ <action>
+ [ a get-global "a" set-value ] >>init
+ [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
+ [ { { "a" [ v-integer ] } } validate-params ] >>validate
+ [ "a" value a set-global URL" " <redirect> ] >>submit
+ <flash-scopes>
+ <sessions>
+ >>default
+ add-quit-action
+ test-db <db-persistence>
+ main-responder set
+
+ [ 1237 httpd ] "HTTPD test" spawn drop
+ ] with-scope
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+3 a set-global
+
+: test-a string>xml "input" tag-named "value" swap at ;
+
+[ "3" ] [
+ "http://localhost:1237/" http-get*
+ swap dup cookies>> "cookies" set session-id-key get-cookie
+ value>> "session-id" set test-a
+] unit-test
+
+[ "4" ] [
+ H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+ "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+] unit-test
+
+[ 4 ] [ a get-global ] unit-test
+
+! Test flash scope
+[ "xyz" ] [
+ H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+ "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+] unit-test
+
+[ 4 ] [ a get-global ] unit-test
+
+[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
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 => , ;
: 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 )
version
header
post-data
-post-data-type
cookies ;
: set-header ( request/response value key -- request/response )
: header ( request/response key -- value )
swap header>> at ;
-SYMBOL: max-post-request
+TUPLE: post-data raw content content-type ;
-1024 256 * max-post-request set-global
+: <post-data> ( raw content-type -- post-data )
+ post-data new
+ swap >>content-type
+ swap >>raw ;
-: content-length ( header -- n )
- "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
+ <post-data> parse-post-data >>post-data
+ ] when ;
: extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri
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* ;
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 ;
: 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" <post-data> ;
+
+M: byte-array >post-data "application/octet-stream" <post-data> ;
+
+M: xml >post-data xml>string "text/xml" <post-data> ;
+
+M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
+
+M: f >post-data ;
+
+: unparse-post-data ( request -- request )
+ [ >post-data ] change-post-data ;
+
: write-post-data ( request -- request )
- dup post-data>> [ write ] when* ;
+ dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
: write-request ( request -- )
unparse-post-data
: 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* ;
request get "accept" header "HTTP_ACCEPT" set\r
\r
post? [\r
- request get post-data-type>> "CONTENT_TYPE" set\r
- request get post-data>> length number>string "CONTENT_LENGTH" set\r
+ request get post-data>> raw>>\r
+ [ "CONTENT_TYPE" set ]\r
+ [ length number>string "CONTENT_LENGTH" set ]\r
+ bi\r
] when\r
] H{ } make-assoc ;\r
\r
"CGI output follows" >>message\r
swap '[\r
, output-stream get swap <cgi-process> <process-stream> [\r
- post? [ request get post-data>> write flush ] when\r
+ post? [ request get post-data>> raw>> write flush ] when\r
input-stream get swap (stream-copy)\r
] with-stream\r
] >>body ;\r
! 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 ;
: <vhost-dispatcher> ( -- dispatcher )
vhost-dispatcher new-dispatcher ;
+: canonical-host ( host -- host' )
+ >lower "www." ?head drop "." ?tail drop ;
+
: find-vhost ( dispatcher -- responder )
- request get url>> host>> over responders>> at*
+ request get url>> host>> canonical-host over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
-namespaces tools.test ;
+namespaces tools.test present ;
\ relative-to-request must-infer
request set
[ "http://www.apple.com:80/xxx/bar" ] [
- <url> relative-to-request url>string
+ <url> relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/baz" ] [
- <url> "baz" >>path relative-to-request url>string
+ <url> "baz" >>path relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [
- <url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
+ <url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/bar?c=d" ] [
- <url> { { "c" "d" } } >>query relative-to-request url>string
+ <url> { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.apple.com:80/flip" ] [
- <url> "/flip" >>path relative-to-request url>string
+ <url> "/flip" >>path relative-to-request present
] unit-test
[ "http://www.apple.com:80/flip?c=d" ] [
- <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
+ <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.jedit.org:80/" ] [
- "http://www.jedit.org" >url relative-to-request url>string
+ "http://www.jedit.org" >url relative-to-request present
] unit-test
[ "http://www.jedit.org:80/?a=b" ] [
- "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string
+ "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present
] unit-test
] with-scope
--- /dev/null
+USING: http http.server math sequences continuations tools.test ;
+IN: http.server.tests
+
+[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
M: trivial-responder call-responder* nip response>> clone ;
-main-responder global [ <404> <trivial-responder> get-global or ] change-at
+main-responder global [ <404> <trivial-responder> or ] change-at
: invert-slice ( slice -- slice' )
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
+ swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
dup write-response
! 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:
! 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
! 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
: 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 ;
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
} set-gestures
-: jamshred-window ( -- )
- [ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
+: jamshred-window ( -- jamshred )
+ [ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
MAIN: jamshred-window
: 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- ;
:: 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 ;
-! 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 ;
[ 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 )
: 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 -- )
- over 0 > [
- {
- [ dup nearest-segment>> bounce ]
- [ sounds>> bang ]
- [ 3/4 swap multiply-player-speed ]
- [ (move-player) ]
- } cleave
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+ dup nearest-segment>> (distance-to-collision) ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
] [
2drop
] if ;
-: move-player-distance ( distance-remaining player distance -- distance-remaining player )
- pick min tuck over go-forward [ - ] dip ;
+:: 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-player) ( distance-remaining player -- )
- over 0 <= [
- 2drop
- ] [
- dup dup nearest-segment>> distance-to-collision
- move-player-distance ?bounce
- ] if ;
+: 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 distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
+ move-toward-wall ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
: move-player ( player -- )
- [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
: update-player ( player -- )
- dup move-player nearest-segment>>
- white swap set-segment-color ;
+ [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
[ { 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
-! 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
TUPLE: segment < oint number color radius ;
C: <segment> segment
-: segment-vertex ( theta segment -- vertex )
- tuck 2dup up>> swap sin v*n
- >r left>> swap cos v*n r> v+
- swap location>> v+ ;
-
-: segment-vertex-normal ( vertex segment -- normal )
- location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
- swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
-
: segment-number++ ( segment -- )
[ number>> 1+ ] keep (>>number) ;
: (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 ;
: <straight-tunnel> ( -- segments )
n-segments simple-segments ;
-: sub-tunnel ( from to sements -- segments )
+: sub-tunnel ( from to segments -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
[ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
[ 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 ;
: 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 ;
: 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?)
-
-: collision-vector ( oint segment -- v )
+: (distance-to-collision) ( oint segment -- distance )
[ sideways-heading ] [ sideways-relative-location ]
- [ bounce-radius ] 2tri
- swap [ collision-coefficient ] dip forward>> n*v ;
+ [ nip radius>> ] 2tri collision-coefficient ;
-: distance-to-collision ( oint segment -- distance )
- collision-vector norm ;
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
: bounce-forward ( segment oint -- )
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
#! 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 ;
! 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
+++ /dev/null
-Chris Double
-Samuel Tardieu
-Matthew Willis
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: lazy-lists.examples lazy-lists tools.test ;
-IN: lazy-lists.examples.tests
-
-[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
-[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
+++ /dev/null
-! Rewritten by Matthew Willis, July 2006
-! 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
-
-: naturals 0 lfrom ;
-: positives 1 lfrom ;
-: evens 0 [ 2 + ] lfrom-by ;
-: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
-: powers-of-2 1 [ 2 * ] lfrom-by ;
-: ones 1 [ ] lfrom-by ;
-: squares naturals [ dup * ] lmap ;
-: first-five-squares 5 squares ltake list>array ;
+++ /dev/null
-! 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." } ;
-
-HELP: lazy-cons
-{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
-{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
-{ $see-also cons car cdr nil nil? } ;
-
-{ 1lazy-list 2lazy-list 3lazy-list } related-words
-
-HELP: 1lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
-
-HELP: 2lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: 3lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: <memoized-cons>
-{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
-{ $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 } ;
-
-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
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: lmap-with
-{ $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." } ;
-
-HELP: ltake
-{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " 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: lfilter
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " 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: lwhile
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: luntil
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: list>vector
-{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
-{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>array } ;
-
-HELP: list>array
-{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
-{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>vector } ;
-
-HELP: lappend
-{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
-{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
-
-HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
-
-HELP: lfrom
-{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
-
-HELP: seq>list
-{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
-{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
-{ $see-also >list } ;
-
-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 } ;
-
-HELP: lconcat
-{ $values { "list" "a list of lists" } { "result" "a list" } }
-{ $description "Concatenates a list of lists together into one list." } ;
-
-HELP: lcartesian-product
-{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
-{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcartesian-product*
-{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
-{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcomp
-{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
-
-HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
-{ $examples
- { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
-} ;
-
-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 }" }
-} ;
-
-HELP: lcontents
-{ $values { "stream" "a stream" } { "result" string } }
-{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
-{ $see-also llines } ;
-
-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 } ;
-
+++ /dev/null
-! 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
-
-[ { 1 2 3 4 } ] [
- { 1 2 3 4 } >list list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
-] unit-test
-
-[ { 5 6 6 7 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
-] unit-test
-
-[ { 5 6 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
-] unit-test
-
-[ { 4 5 6 } ] [
- 3 { 1 2 3 } >list [ + ] lmap-with list>array
-] unit-test
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-!
-USING: kernel sequences math vectors arrays namespaces
-quotations promises combinators io ;
-IN: lazy-lists
-
-! Lazy List Protocol
-MIXIN: list
-GENERIC: car ( cons -- car )
-GENERIC: cdr ( cons -- cdr )
-GENERIC: nil? ( cons -- ? )
-
-M: promise car ( promise -- car )
- force car ;
-
-M: promise cdr ( promise -- cdr )
- force cdr ;
-
-M: promise nil? ( cons -- bool )
- force nil? ;
-
-TUPLE: cons car cdr ;
-
-C: cons cons
-
-M: cons car ( cons -- car )
- cons-car ;
-
-M: cons cdr ( cons -- cdr )
- cons-cdr ;
-
-: nil ( -- cons )
- T{ cons f f f } ;
-
-M: cons nil? ( cons -- bool )
- nil eq? ;
-
-: 1list ( obj -- cons )
- nil cons ;
-
-: 2list ( a b -- cons )
- nil cons cons ;
-
-: 3list ( a b c -- cons )
- nil cons cons cons ;
-
-! Both 'car' and 'cdr' are promises
-TUPLE: lazy-cons car cdr ;
-
-: lazy-cons ( car cdr -- promise )
- [ promise ] bi@ \ lazy-cons boa
- T{ promise f f t f } clone
- [ set-promise-value ] keep ;
-
-M: lazy-cons car ( lazy-cons -- car )
- lazy-cons-car force ;
-
-M: lazy-cons cdr ( lazy-cons -- cdr )
- lazy-cons-cdr force ;
-
-M: lazy-cons nil? ( lazy-cons -- bool )
- nil eq? ;
-
-: 1lazy-list ( a -- lazy-cons )
- [ nil ] lazy-cons ;
-
-: 2lazy-list ( a b -- lazy-cons )
- 1lazy-list 1quotation lazy-cons ;
-
-: 3lazy-list ( a b c -- lazy-cons )
- 2lazy-list 1quotation lazy-cons ;
-
-: lnth ( n list -- elt )
- swap [ cdr ] times car ;
-
-: (llength) ( list acc -- n )
- over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
-
-: llength ( list -- n )
- 0 (llength) ;
-
-: uncons ( cons -- car cdr )
- #! Return the car and cdr of the lazy list
- dup car swap cdr ;
-
-: leach ( list quot -- )
- swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
-
-: lreduce ( list identity quot -- result )
- swapd leach ; inline
-
-TUPLE: memoized-cons original car cdr nil? ;
-
-: not-memoized ( -- obj )
- { } ;
-
-: not-memoized? ( obj -- bool )
- not-memoized eq? ;
-
-: <memoized-cons> ( cons -- memoized-cons )
- not-memoized not-memoized not-memoized
- memoized-cons boa ;
-
-M: memoized-cons car ( memoized-cons -- car )
- dup memoized-cons-car not-memoized? [
- dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
- ] [
- memoized-cons-car
- ] if ;
-
-M: memoized-cons cdr ( memoized-cons -- cdr )
- dup memoized-cons-cdr not-memoized? [
- dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
- ] [
- memoized-cons-cdr
- ] if ;
-
-M: memoized-cons nil? ( memoized-cons -- bool )
- dup memoized-cons-nil? not-memoized? [
- dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
- ] [
- memoized-cons-nil?
- ] if ;
-
-TUPLE: lazy-map cons quot ;
-
-C: <lazy-map> lazy-map
-
-: lmap ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
-
-M: lazy-map car ( lazy-map -- car )
- [ lazy-map-cons car ] keep
- lazy-map-quot call ;
-
-M: lazy-map cdr ( lazy-map -- cdr )
- [ lazy-map-cons cdr ] keep
- lazy-map-quot lmap ;
-
-M: lazy-map nil? ( lazy-map -- bool )
- lazy-map-cons nil? ;
-
-: lmap-with ( value list quot -- result )
- with lmap ;
-
-TUPLE: lazy-take n cons ;
-
-C: <lazy-take> lazy-take
-
-: ltake ( n list -- result )
- over zero? [ 2drop nil ] [ <lazy-take> ] if ;
-
-M: lazy-take car ( lazy-take -- car )
- lazy-take-cons car ;
-
-M: lazy-take cdr ( lazy-take -- cdr )
- [ lazy-take-n 1- ] keep
- lazy-take-cons cdr ltake ;
-
-M: lazy-take nil? ( lazy-take -- bool )
- dup lazy-take-n zero? [
- drop t
- ] [
- lazy-take-cons nil?
- ] if ;
-
-TUPLE: lazy-until cons quot ;
-
-C: <lazy-until> lazy-until
-
-: luntil ( list quot -- result )
- over nil? [ drop ] [ <lazy-until> ] if ;
-
-M: lazy-until car ( lazy-until -- car )
- lazy-until-cons car ;
-
-M: lazy-until cdr ( lazy-until -- cdr )
- [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
- [ 2drop nil ] [ luntil ] if ;
-
-M: lazy-until nil? ( lazy-until -- bool )
- drop f ;
-
-TUPLE: lazy-while cons quot ;
-
-C: <lazy-while> lazy-while
-
-: lwhile ( list quot -- result )
- over nil? [ drop ] [ <lazy-while> ] if ;
-
-M: lazy-while car ( lazy-while -- car )
- lazy-while-cons car ;
-
-M: lazy-while cdr ( lazy-while -- cdr )
- [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
-
-M: lazy-while nil? ( lazy-while -- bool )
- [ car ] keep lazy-while-quot call not ;
-
-TUPLE: lazy-filter cons quot ;
-
-C: <lazy-filter> lazy-filter
-
-: lfilter ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
-
-: car-filter? ( lazy-filter -- ? )
- [ lazy-filter-cons car ] keep
- lazy-filter-quot call ;
-
-: skip ( lazy-filter -- )
- [ lazy-filter-cons cdr ] keep
- set-lazy-filter-cons ;
-
-M: lazy-filter car ( lazy-filter -- car )
- dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
-
-M: lazy-filter cdr ( lazy-filter -- cdr )
- dup car-filter? [
- [ lazy-filter-cons cdr ] keep
- lazy-filter-quot lfilter
- ] [
- dup skip cdr
- ] if ;
-
-M: lazy-filter nil? ( lazy-filter -- bool )
- dup lazy-filter-cons nil? [
- drop t
- ] [
- dup car-filter? [
- drop f
- ] [
- dup skip nil?
- ] if
- ] if ;
-
-: list>vector ( list -- vector )
- [ [ , ] leach ] V{ } make ;
-
-: list>array ( list -- array )
- [ [ , ] leach ] { } make ;
-
-TUPLE: lazy-append list1 list2 ;
-
-C: <lazy-append> lazy-append
-
-: lappend ( list1 list2 -- result )
- over nil? [ nip ] [ <lazy-append> ] if ;
-
-M: lazy-append car ( lazy-append -- car )
- lazy-append-list1 car ;
-
-M: lazy-append cdr ( lazy-append -- cdr )
- [ lazy-append-list1 cdr ] keep
- lazy-append-list2 lappend ;
-
-M: lazy-append nil? ( lazy-append -- bool )
- drop f ;
-
-TUPLE: lazy-from-by n quot ;
-
-C: lfrom-by lazy-from-by ( n quot -- list )
-
-: lfrom ( n -- list )
- [ 1+ ] lfrom-by ;
-
-M: lazy-from-by car ( lazy-from-by -- car )
- lazy-from-by-n ;
-
-M: lazy-from-by cdr ( lazy-from-by -- cdr )
- [ lazy-from-by-n ] keep
- lazy-from-by-quot dup slip lfrom-by ;
-
-M: lazy-from-by nil? ( lazy-from-by -- bool )
- drop f ;
-
-TUPLE: lazy-zip list1 list2 ;
-
-C: <lazy-zip> lazy-zip
-
-: lzip ( list1 list2 -- lazy-zip )
- over nil? over nil? or
- [ 2drop nil ] [ <lazy-zip> ] if ;
-
-M: lazy-zip car ( lazy-zip -- car )
- [ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
-
-M: lazy-zip cdr ( lazy-zip -- cdr )
- [ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
-
-M: lazy-zip nil? ( lazy-zip -- bool )
- drop f ;
-
-TUPLE: sequence-cons index seq ;
-
-C: <sequence-cons> sequence-cons
-
-: seq>list ( index seq -- list )
- 2dup length >= [
- 2drop nil
- ] [
- <sequence-cons>
- ] if ;
-
-M: sequence-cons car ( sequence-cons -- car )
- [ sequence-cons-index ] keep
- sequence-cons-seq nth ;
-
-M: sequence-cons cdr ( sequence-cons -- cdr )
- [ sequence-cons-index 1+ ] keep
- sequence-cons-seq seq>list ;
-
-M: sequence-cons nil? ( sequence-cons -- bool )
- drop f ;
-
-: >list ( object -- list )
- {
- { [ dup sequence? ] [ 0 swap seq>list ] }
- { [ dup list? ] [ ] }
- [ "Could not convert object to a list" throw ]
- } cond ;
-
-TUPLE: lazy-concat car cdr ;
-
-C: <lazy-concat> lazy-concat
-
-DEFER: lconcat
-
-: (lconcat) ( car cdr -- list )
- over nil? [
- nip lconcat
- ] [
- <lazy-concat>
- ] if ;
-
-: lconcat ( list -- result )
- dup nil? [
- drop nil
- ] [
- uncons (lconcat)
- ] if ;
-
-M: lazy-concat car ( lazy-concat -- car )
- lazy-concat-car car ;
-
-M: lazy-concat cdr ( lazy-concat -- cdr )
- [ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
-
-M: lazy-concat nil? ( lazy-concat -- bool )
- dup lazy-concat-car nil? [
- lazy-concat-cdr nil?
- ] [
- drop f
- ] if ;
-
-: lcartesian-product ( list1 list2 -- result )
- swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
-
-: lcartesian-product* ( lists -- result )
- dup nil? [
- drop nil
- ] [
- [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
- swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
- ] reduce
- ] if ;
-
-: lcomp ( list quot -- result )
- [ lcartesian-product* ] dip lmap ;
-
-: lcomp* ( list guards quot -- result )
- [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
-
-DEFER: lmerge
-
-: (lmerge) ( list1 list2 -- result )
- over [ car ] curry -rot
- [
- dup [ car ] curry -rot
- [
- [ cdr ] bi@ lmerge
- ] 2curry lazy-cons
- ] 2curry lazy-cons ;
-
-: lmerge ( list1 list2 -- result )
- {
- { [ over nil? ] [ nip ] }
- { [ dup nil? ] [ drop ] }
- { [ t ] [ (lmerge) ] }
- } cond ;
-
-TUPLE: lazy-io stream car cdr quot ;
-
-C: <lazy-io> lazy-io
-
-: lcontents ( stream -- result )
- f f [ stream-read1 ] <lazy-io> ;
-
-: llines ( stream -- result )
- f f [ stream-readln ] <lazy-io> ;
-
-M: lazy-io car ( lazy-io -- car )
- dup lazy-io-car dup [
- nip
- ] [
- drop dup lazy-io-stream over lazy-io-quot call
- swap dupd set-lazy-io-car
- ] if ;
-
-M: lazy-io cdr ( lazy-io -- cdr )
- dup lazy-io-cdr dup [
- nip
- ] [
- drop dup
- [ lazy-io-stream ] keep
- [ lazy-io-quot ] keep
- car [
- [ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
- ] [
- 3drop nil
- ] if
- ] if ;
-
-M: lazy-io nil? ( lazy-io -- bool )
- car not ;
-
-INSTANCE: cons list
-INSTANCE: sequence-cons list
-INSTANCE: memoized-cons list
-INSTANCE: promise list
-INSTANCE: lazy-io list
-INSTANCE: lazy-concat list
-INSTANCE: lazy-cons list
-INSTANCE: lazy-map list
-INSTANCE: lazy-take list
-INSTANCE: lazy-append list
-INSTANCE: lazy-from-by list
-INSTANCE: lazy-zip list
-INSTANCE: lazy-while list
-INSTANCE: lazy-until list
-INSTANCE: lazy-filter list
+++ /dev/null
-<html>
- <head>
- <title>Lazy Evaluation</title>
- <link rel="stylesheet" type="text/css" href="style.css">
- </head>
- <body>
- <h1>Lazy Evaluation</h1>
-<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
- ability to describe infinite structures, and to delay execution of
- expressions until they are actually used.</p>
-<p>Lazy lists, like normal lists, are composed of a head and tail. In
- a lazy list the head and tail are something called a 'promise'.
- To convert a
- 'promise' into its actual value a word called 'force' is used. To
- convert a value into a 'promise' the word to use is 'delay'.</p>
-<table border="1">
-<tr><td><a href="#delay">delay</a></td></tr>
-<tr><td><a href="#force">force</a></td></tr>
-</table>
-
-<p>Many of the lazy list words are named similar to the standard list
- words but with an 'l' suffixed to it. Here are the commonly used
- words and their equivalent list operation:</p>
-<table border="1">
-<tr><th>Lazy List</th><th>Normal List</th></tr>
-<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
-<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
-<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
-<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
-<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
-<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
-<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
-<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
-<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
-<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
-<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
-<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
-</table>
-<p>A few additional words specific to lazy lists are:</p>
-<table border="1">
-<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
-number of items from the lazy list.</td></tr>
-<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
-concatenate them together in a lazy manner, returning a single lazy
-list.</td></tr>
-<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
-that contains the same elements as the normal list.</td></tr>
-</table>
-<h2>Reference</h2>
-<!-- delay description -->
-<a name="delay">
-<h3>delay ( quot -- <promise> )</h3>
-<p>'delay' is used to convert a value or expression into a promise.
- The word 'force' is used to convert that promise back to its
- value, or to force evaluation of the expression to return a value.
-</p>
-<p>The value on the stack that 'delay' expects must be quoted. This is
- a requirement to prevent it from being evaluated.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- force description -->
-<a name="force">
-<h3>force ( <promise> -- value )</h3>
-<p>'force' will evaluate a promises original expression
- and leave the value of that expression on the stack.
-</p>
-<p>A promise can be forced multiple times but the expression
- is only evaluated once. Future calls of 'force' on the promise
- will returned the cached value of the original force. If the
- expression contains side effects, such as i/o, then that i/o
- will only occur on the first 'force'. See below for an example
- (steps 3-5).
-</p>
-<p>If a promise is itself delayed, a force will evaluate all promises
- until a value is returned. Due to this behaviour it is generally not
- possible to delay a promise. The example below shows what happens
- in this case.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-
- #! Multiple forces on a promise returns cached value
- ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
- ( 4 ) dup <a href="#force">force</a> .
- => hello
- 42
- ( 5 ) <a href="#force">force</a> .
- => 42
-
- #! Forcing a delayed promise cascades up to return
- #! original value, rather than the promise.
- ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
- ( 7 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- lnil description -->
-<a name="lnil">
-<h3>lnil ( -- lcons )</h3>
-<p>Returns a value representing the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> .
- => << promise [ ] [ [ ] ] t [ ] >>
-</pre>
-
-<!-- lnil description -->
-<a name="lnilp">
-<h3>lnil? ( lcons -- bool )</h3>
-<p>Returns true if the given lazy cons is the value representing
- the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
- => [ ]
- ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
-</pre>
-
-<!-- lcons description -->
-<a name="lcons">
-<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
-<p>Provides the same effect as 'cons' does for normal lists.
- Both values provided must be promises (ie. expressions that have
- had <a href="#delay">delay</a> called on them).
-</p>
-<p>As the car and cdr passed on the stack are promises, they are not
- evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
- are called on the lazy cons.</p>
-<pre class="code">
- ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => "car"
- ( 3 ) dup <a href="#lcdr">lcdr</a> .
- => "cdr"
-</pre>
-
-<!-- lunit description -->
-<a name="lunit">
-<h3>lunit ( value-promise -- llist )</h3>
-<p>Provides the same effect as 'unit' does for normal lists. It
-creates a lazy list where the first element is the value given.</p>
-<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
- a promise and is not evaluated until the <a href="#lcar">lcar</a>
- of the list is requested.</a>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => 42
- ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 4 ) [ . ] <a href="#leach">leach</a>
- => 42
-</pre>
-
-<!-- lcar description -->
-<a name="lcar">
-<h3>lcar ( lcons -- value )</h3>
-<p>Provides the same effect as 'car' does for normal lists. It
-returns the first element in a lazy cons cell. This will force
-the evaluation of that element.</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcar">lcar</a> .
- => 42
-</pre>
-
-<!-- lcdr description -->
-<a name="lcdr">
-<h3>lcdr ( lcons -- value )</h3>
-<p>Provides the same effect as 'cdr' does for normal lists. It
-returns the second element in a lazy cons cell and forces it. This
-causes that element to be evaluated immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> .
- => 11
-</pre>
-
-<pre class="code">
- ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 6
- ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 7
- ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 8
-</pre>
-
-<!-- lnth description -->
-<a name="lnth">
-<h3>lnth ( n llist -- value )</h3>
-<p>Provides the same effect as 'nth' does for normal lists. It
-returns the nth value in the lazy list. It causes all the values up to
-'n' to be evaluated.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) 5 swap <a href="#lnth">lnth</a> .
- => 6
-</pre>
-
-<!-- luncons description -->
-<a name="luncons">
-<h3>luncons ( lcons -- car cdr )</h3>
-<p>Provides the same effect as 'uncons' does for normal lists. It
-returns the car and cdr of the lazy list.</p>
-<pre class="code">
- ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#luncons">luncons</a> . .
- => 6
- 5
-</pre>
-
-<!-- lmap description -->
-<a name="lmap">
-<h3>lmap ( llist quot -- llist )</h3>
-<p>Lazily maps over a lazy list applying the quotation to each element.
-A new lazy list is returned which contains the results of the
-quotation.</p>
-<p>When intially called nothing in the original lazy list is
-evaluated. Only when <a href="#lcar">lcar</a> is called will the item
-in the list be evaluated and applied to the quotation. Ditto with <a
-href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
- => < infinite list of numbers incrementing by 2 >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 4 6 8 10 ]
-</pre>
-
-<!-- lsubset description -->
-<a name="lsubset">
-<h3>lsubset ( llist pred -- llist )</h3>
-<p>Provides the same effect as 'subset' does for normal lists. It
-lazily iterates over a lazy list applying the predicate quotation to each
-element. If that quotation returns true, the element will be included
-in the resulting lazy list. If it is false, the element will be skipped.
-A new lazy list is returned which contains all elements where the
-predicate returned true.</p>
-<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
-will occur. A lazy list is returned that when values are retrieved
-from in then items are evaluated and checked against the predicate.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
- => < infinite list of prime numbers >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 3 5 7 11 ]
-</pre>
-
-<!-- leach description -->
-<a name="leach">
-<h3>leach ( llist quot -- )</h3>
-<p>Provides the same effect as 'each' does for normal lists. It
-lazily iterates over a lazy list applying the quotation to each
-element. If this operation is applied to an infinite list it will
-never return unless the quotation escapes out by calling a continuation.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
- => < infinite list of odd numbers >
- ( 3 ) [ . ] <a href="#leach">leach</a>
- => 1
- 3
- 5
- 7
- ... for ever ...
-</pre>
-
-<!-- ltake description -->
-<a name="ltake">
-<h3>ltake ( n llist -- llist )</h3>
-<p>Iterates over the lazy list 'n' times, appending each element to a
-lazy list. This provides a convenient way of getting elements out of
-an infinite lazy list.</p>
-<pre class="code">
- ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
- ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 1 1 1 1 1 ]
-</pre>
-
-<!-- lappend description -->
-<a name="lappend">
-<h3>lappend ( llist1 llist2 -- llist )</h3>
-<p>Lazily appends two lists together. The actual appending is done
-lazily on iteration rather than immediately so it works very fast no
-matter how large the list.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
-</pre>
-
-<!-- lappend* description -->
-<a name="lappendstar">
-<h3>lappend* ( llists -- llist )</h3>
-<p>Given a lazy list of lazy lists, concatenate them together in a
-lazy fashion. The actual appending is done lazily on iteration rather
-than immediately so it works very fast no matter how large the lists.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
- ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
- ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
- ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
- ( 5 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
-</pre>
-
-<!-- list>llist description -->
-<a name="list2llist">
-<h3>list>llist ( list -- llist )</h3>
-<p>Converts a normal list into a lazy list. This is done lazily so the
-initial list is not iterated through immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
-</pre>
-
-<p class="footer">
-News and updates to this software can be obtained from the authors
-weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
-<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
-</body> </html>
+++ /dev/null
-Lazy lists
+++ /dev/null
-extensions
-collections
! 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
"#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 ] "+" <lisp-symbol> funcall
] 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
{ 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
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
-namespaces combinators math bake locals locals.private accessors
+namespaces combinators math locals locals.private accessors
vectors syntax lisp.parser assocs parser sequences.lib words quotations
-fry ;
+fry lists inspector ;
IN: lisp
DEFER: convert-form
DEFER: funcall
DEFER: lookup-var
+DEFER: lisp-macro?
+DEFER: lookup-macro
+DEFER: macro-call
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: convert-body ( s-exp -- quot )
- [ ] [ convert-form compose ] reduce ; inline
+: convert-body ( cons -- quot )
+ [ ] [ convert-form compose ] foldl ; inline
-: convert-if ( s-exp -- quot )
- rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
+: convert-if ( cons -- quot )
+ cdr 3car [ convert-form ] tri@ '[ @ , , if ] ;
-: 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
<PRIVATE
: localize-body ( assoc body -- assoc newbody )
- [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
- [ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
- ] map ;
+ dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ]
+ [ dup cons? [ localize-body ] when nip ] if
+ ] with lmap>array ;
: localize-lambda ( body vars -- newbody newvars )
make-locals dup push-locals swap
- [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
+ [ swap localize-body seq>cons 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 <lambda>
'[ , cut '[ @ , ] , compose ] ;
localize-lambda <lambda> '[ , compose ] ;
PRIVATE>
-: convert-lambda ( s-exp -- quot )
+: convert-lambda ( cons -- quot )
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
-: convert-quoted ( s-exp -- quot )
- second 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-quoted ( cons -- quot )
+ cdr 1quotation ;
+
+: convert-unquoted ( cons -- quot )
+ "unquote not valid outside of quasiquote!" throw ;
+
+: convert-quasiquoted ( cons -- newcons )
+ [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
+ [ cadr ] traverse ;
+
+: form-dispatch ( lisp-symbol -- quot )
+ name>>
+ { { "lambda" [ convert-lambda ] }
+ { "quote" [ convert-quoted ] }
+ { "unquote" [ convert-unquoted ] }
+ { "quasiquote" [ convert-quasiquoted ] }
+ { "if" [ convert-if ] }
+ { "begin" [ convert-begin ] }
+ { "cond" [ convert-cond ] }
+ [ drop convert-general-form ]
+ } case ;
+
+: macro-expand ( cons -- quot )
+ uncons lookup-macro macro-call convert-form ;
+
+: convert-list-form ( cons -- quot )
+ dup car
+ { { [ dup lisp-macro? ] [ macro-expand ] }
+ { [ dup lisp-symbol? ] [ form-dispatch ] }
+ [ drop convert-general-form ]
+ } cond ;
: convert-form ( lisp-form -- quot )
- { { [ dup s-exp? ] [ body>> convert-list-form ] }
- { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
- [ 1quotation ]
+ {
+ { [ dup cons? ] [ convert-list-form ] }
+ { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
+ [ 1quotation ]
} cond ;
: lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast convert-form lambda-rewrite call ;
+: lisp-eval ( str -- * )
+ lisp-string>factor call ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env
ERROR: no-such-var var ;
+
+SYMBOL: macro-env
+
+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-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 ;
: 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 ] lisp-define ;
+
+: lookup-macro ( lisp-symbol -- macro )
+ name>> macro-env get at ;
+
+: lisp-macro? ( car -- ? )
+ dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
! 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
] 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
! 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> lisp-symbol
-TUPLE: s-exp body ;
-C: <s-exp> s-exp
-
EBNF: lisp-expr
_ = (" " | "\t" | "\n")*
LPAREN = "("
number = float
| rational
| integer
-id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
- | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
+id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
+ | "<" | "#" | " =" | ">" | "?" | "^" | "_"
+ | "~" | "+" | "-" | "." | "@"
letters = [a-zA-Z] => [[ 1array >string ]]
initials = letters | id-specials
numbers = [0-9] => [[ 1array >string ]]
atom = number
| identifier
| string
-list-item = _ (atom|s-expression) _ => [[ second ]]
-s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
+list-item = _ ( atom | s-expression ) _ => [[ second ]]
+s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
;EBNF
\ No newline at end of file
--- /dev/null
+James Cash
--- /dev/null
+Chris Double
+Samuel Tardieu
+Matthew Willis
--- /dev/null
+Chris Double
--- /dev/null
+USING: lazy-lists.examples lazy-lists tools.test ;
+IN: lazy-lists.examples.tests
+
+[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
+[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
--- /dev/null
+! Rewritten by Matthew Willis, July 2006
+! 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
+
+: naturals 0 lfrom ;
+: positives 1 lfrom ;
+: evens 0 [ 2 + ] lfrom-by ;
+: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
+: powers-of-2 1 [ 2 * ] lfrom-by ;
+: ones 1 [ ] lfrom-by ;
+: squares naturals [ dup * ] lazy-map ;
+: first-five-squares 5 squares ltake list>array ;
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+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" } }
+{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
+{ $see-also cons car cdr nil nil? } ;
+
+{ 1lazy-list 2lazy-list 3lazy-list } related-words
+
+HELP: 1lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
+
+HELP: 2lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: 3lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: <memoized-cons>
+{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
+{ $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? } ;
+
+{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+
+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 <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: 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 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" } }
+{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " 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: lfilter
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
+{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " 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: lwhile
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: luntil
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: list>vector
+{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
+{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>array } ;
+
+HELP: list>array
+{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
+{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>vector } ;
+
+HELP: lappend
+{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
+{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
+
+HELP: lfrom-by
+{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
+
+HELP: lfrom
+{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
+
+HELP: seq>list
+{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
+{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
+{ $see-also >list } ;
+
+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" } }
+{ $description "Concatenates a list of lists together into one list." } ;
+
+HELP: lcartesian-product
+{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
+{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcartesian-product*
+{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
+{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcomp
+{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
+
+HELP: lcomp*
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
+{ $examples
+ { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
+} ;
+
+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 }" }
+} ;
+
+HELP: lcontents
+{ $values { "stream" "a stream" } { "result" string } }
+{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
+{ $see-also llines } ;
+
+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 } ;
+
--- /dev/null
+! Copyright (C) 2006 Matthew Willis and Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+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
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
+] unit-test
+
+[ { 5 6 6 7 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
+] unit-test
+
+[ { 5 6 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
+] unit-test
+
+[ { 4 5 6 } ] [
+ 3 { 1 2 3 } >list [ + ] lazy-map-with list>array
+] unit-test
--- /dev/null
+! Copyright (C) 2004 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Updated by Matthew Willis, July 2006
+! Updated by Chris Double, September 2006
+! Updated by James Cash, June 2008
+!
+USING: kernel sequences math vectors arrays namespaces
+quotations promises combinators io lists accessors ;
+IN: lists.lazy
+
+M: promise car ( promise -- car )
+ force car ;
+
+M: promise cdr ( promise -- cdr )
+ force cdr ;
+
+M: promise nil? ( cons -- bool )
+ force nil? ;
+
+! Both 'car' and 'cdr' are promises
+TUPLE: lazy-cons car cdr ;
+
+: lazy-cons ( car cdr -- promise )
+ [ promise ] bi@ \ lazy-cons boa
+ T{ promise f f t f } clone
+ [ set-promise-value ] keep ;
+
+M: lazy-cons car ( lazy-cons -- car )
+ car>> force ;
+
+M: lazy-cons cdr ( lazy-cons -- cdr )
+ cdr>> force ;
+
+M: lazy-cons nil? ( lazy-cons -- bool )
+ nil eq? ;
+
+: 1lazy-list ( a -- lazy-cons )
+ [ nil ] lazy-cons ;
+
+: 2lazy-list ( a b -- lazy-cons )
+ 1lazy-list 1quotation lazy-cons ;
+
+: 3lazy-list ( a b c -- lazy-cons )
+ 2lazy-list 1quotation lazy-cons ;
+
+TUPLE: memoized-cons original car cdr nil? ;
+
+: not-memoized ( -- obj )
+ { } ;
+
+: not-memoized? ( obj -- bool )
+ not-memoized eq? ;
+
+: <memoized-cons> ( cons -- memoized-cons )
+ not-memoized not-memoized not-memoized
+ memoized-cons boa ;
+
+M: memoized-cons car ( memoized-cons -- car )
+ dup car>> not-memoized? [
+ dup original>> car [ >>car drop ] keep
+ ] [
+ car>>
+ ] if ;
+
+M: memoized-cons cdr ( memoized-cons -- cdr )
+ dup cdr>> not-memoized? [
+ dup original>> cdr [ >>cdr drop ] keep
+ ] [
+ cdr>>
+ ] if ;
+
+M: memoized-cons nil? ( memoized-cons -- bool )
+ dup nil?>> not-memoized? [
+ dup original>> nil? [ >>nil? drop ] keep
+ ] [
+ nil?>>
+ ] if ;
+
+TUPLE: lazy-map cons quot ;
+
+C: <lazy-map> lazy-map
+
+: lazy-map ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
+
+M: lazy-map car ( lazy-map -- car )
+ [ cons>> car ] keep
+ quot>> call ;
+
+M: lazy-map cdr ( lazy-map -- cdr )
+ [ cons>> cdr ] keep
+ quot>> lazy-map ;
+
+M: lazy-map nil? ( lazy-map -- bool )
+ cons>> nil? ;
+
+: lazy-map-with ( value list quot -- result )
+ with lazy-map ;
+
+TUPLE: lazy-take n cons ;
+
+C: <lazy-take> lazy-take
+
+: ltake ( n list -- result )
+ over zero? [ 2drop nil ] [ <lazy-take> ] if ;
+
+M: lazy-take car ( lazy-take -- car )
+ cons>> car ;
+
+M: lazy-take cdr ( lazy-take -- cdr )
+ [ n>> 1- ] keep
+ cons>> cdr ltake ;
+
+M: lazy-take nil? ( lazy-take -- bool )
+ dup n>> zero? [
+ drop t
+ ] [
+ cons>> nil?
+ ] if ;
+
+TUPLE: lazy-until cons quot ;
+
+C: <lazy-until> lazy-until
+
+: luntil ( list quot -- result )
+ over nil? [ drop ] [ <lazy-until> ] if ;
+
+M: lazy-until car ( lazy-until -- car )
+ cons>> car ;
+
+M: lazy-until cdr ( lazy-until -- cdr )
+ [ cons>> uncons ] keep quot>> tuck call
+ [ 2drop nil ] [ luntil ] if ;
+
+M: lazy-until nil? ( lazy-until -- bool )
+ drop f ;
+
+TUPLE: lazy-while cons quot ;
+
+C: <lazy-while> lazy-while
+
+: lwhile ( list quot -- result )
+ over nil? [ drop ] [ <lazy-while> ] if ;
+
+M: lazy-while car ( lazy-while -- car )
+ cons>> car ;
+
+M: lazy-while cdr ( lazy-while -- cdr )
+ [ cons>> cdr ] keep quot>> lwhile ;
+
+M: lazy-while nil? ( lazy-while -- bool )
+ [ car ] keep quot>> call not ;
+
+TUPLE: lazy-filter cons quot ;
+
+C: <lazy-filter> lazy-filter
+
+: lfilter ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
+
+: car-filter? ( lazy-filter -- ? )
+ [ cons>> car ] [ quot>> ] bi call ;
+
+: skip ( lazy-filter -- )
+ dup cons>> cdr >>cons drop ;
+
+M: lazy-filter car ( lazy-filter -- car )
+ dup car-filter? [ cons>> ] [ dup skip ] if car ;
+
+M: lazy-filter cdr ( lazy-filter -- cdr )
+ dup car-filter? [
+ [ cons>> cdr ] [ quot>> ] bi lfilter
+ ] [
+ dup skip cdr
+ ] if ;
+
+M: lazy-filter nil? ( lazy-filter -- bool )
+ dup cons>> nil? [
+ drop t
+ ] [
+ dup car-filter? [
+ drop f
+ ] [
+ dup skip nil?
+ ] if
+ ] if ;
+
+: list>vector ( list -- vector )
+ [ [ , ] leach ] V{ } make ;
+
+: list>array ( list -- array )
+ [ [ , ] leach ] { } make ;
+
+TUPLE: lazy-append list1 list2 ;
+
+C: <lazy-append> lazy-append
+
+: lappend ( list1 list2 -- result )
+ over nil? [ nip ] [ <lazy-append> ] if ;
+
+M: lazy-append car ( lazy-append -- car )
+ list1>> car ;
+
+M: lazy-append cdr ( lazy-append -- cdr )
+ [ list1>> cdr ] keep
+ list2>> lappend ;
+
+M: lazy-append nil? ( lazy-append -- bool )
+ drop f ;
+
+TUPLE: lazy-from-by n quot ;
+
+C: lfrom-by lazy-from-by ( n quot -- list )
+
+: lfrom ( n -- list )
+ [ 1+ ] lfrom-by ;
+
+M: lazy-from-by car ( lazy-from-by -- car )
+ n>> ;
+
+M: lazy-from-by cdr ( lazy-from-by -- cdr )
+ [ n>> ] keep
+ quot>> dup slip lfrom-by ;
+
+M: lazy-from-by nil? ( lazy-from-by -- bool )
+ drop f ;
+
+TUPLE: lazy-zip list1 list2 ;
+
+C: <lazy-zip> lazy-zip
+
+: lzip ( list1 list2 -- lazy-zip )
+ over nil? over nil? or
+ [ 2drop nil ] [ <lazy-zip> ] if ;
+
+M: lazy-zip car ( lazy-zip -- car )
+ [ list1>> car ] keep list2>> car 2array ;
+
+M: lazy-zip cdr ( lazy-zip -- cdr )
+ [ list1>> cdr ] keep list2>> cdr lzip ;
+
+M: lazy-zip nil? ( lazy-zip -- bool )
+ drop f ;
+
+TUPLE: sequence-cons index seq ;
+
+C: <sequence-cons> sequence-cons
+
+: seq>list ( index seq -- list )
+ 2dup length >= [
+ 2drop nil
+ ] [
+ <sequence-cons>
+ ] if ;
+
+M: sequence-cons car ( sequence-cons -- car )
+ [ index>> ] keep
+ seq>> nth ;
+
+M: sequence-cons cdr ( sequence-cons -- cdr )
+ [ index>> 1+ ] keep
+ seq>> seq>list ;
+
+M: sequence-cons nil? ( sequence-cons -- bool )
+ drop f ;
+
+: >list ( object -- list )
+ {
+ { [ dup sequence? ] [ 0 swap seq>list ] }
+ { [ dup list? ] [ ] }
+ [ "Could not convert object to a list" throw ]
+ } cond ;
+
+TUPLE: lazy-concat car cdr ;
+
+C: <lazy-concat> lazy-concat
+
+DEFER: lconcat
+
+: (lconcat) ( car cdr -- list )
+ over nil? [
+ nip lconcat
+ ] [
+ <lazy-concat>
+ ] if ;
+
+: lconcat ( list -- result )
+ dup nil? [
+ drop nil
+ ] [
+ uncons swap (lconcat)
+ ] if ;
+
+M: lazy-concat car ( lazy-concat -- car )
+ car>> car ;
+
+M: lazy-concat cdr ( lazy-concat -- cdr )
+ [ car>> cdr ] keep cdr>> (lconcat) ;
+
+M: lazy-concat nil? ( lazy-concat -- bool )
+ dup car>> nil? [
+ cdr>> nil?
+ ] [
+ drop f
+ ] if ;
+
+: lcartesian-product ( list1 list2 -- result )
+ swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ;
+
+: lcartesian-product* ( lists -- result )
+ dup nil? [
+ drop nil
+ ] [
+ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
+ swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat
+ ] reduce
+ ] if ;
+
+: lcomp ( list quot -- result )
+ [ lcartesian-product* ] dip lazy-map ;
+
+: lcomp* ( list guards quot -- result )
+ [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
+
+DEFER: lmerge
+
+: (lmerge) ( list1 list2 -- result )
+ over [ car ] curry -rot
+ [
+ dup [ car ] curry -rot
+ [
+ [ cdr ] bi@ lmerge
+ ] 2curry lazy-cons
+ ] 2curry lazy-cons ;
+
+: lmerge ( list1 list2 -- result )
+ {
+ { [ over nil? ] [ nip ] }
+ { [ dup nil? ] [ drop ] }
+ { [ t ] [ (lmerge) ] }
+ } cond ;
+
+TUPLE: lazy-io stream car cdr quot ;
+
+C: <lazy-io> lazy-io
+
+: lcontents ( stream -- result )
+ f f [ stream-read1 ] <lazy-io> ;
+
+: llines ( stream -- result )
+ f f [ stream-readln ] <lazy-io> ;
+
+M: lazy-io car ( lazy-io -- car )
+ dup car>> dup [
+ nip
+ ] [
+ drop dup stream>> over quot>> call
+ swap dupd set-lazy-io-car
+ ] if ;
+
+M: lazy-io cdr ( lazy-io -- cdr )
+ dup cdr>> dup [
+ nip
+ ] [
+ drop dup
+ [ stream>> ] keep
+ [ quot>> ] keep
+ car [
+ [ f f ] dip <lazy-io> [ >>cdr drop ] keep
+ ] [
+ 3drop nil
+ ] if
+ ] if ;
+
+M: lazy-io nil? ( lazy-io -- bool )
+ car not ;
+
+INSTANCE: sequence-cons list
+INSTANCE: memoized-cons list
+INSTANCE: promise list
+INSTANCE: lazy-io list
+INSTANCE: lazy-concat list
+INSTANCE: lazy-cons list
+INSTANCE: lazy-map list
+INSTANCE: lazy-take list
+INSTANCE: lazy-append list
+INSTANCE: lazy-from-by list
+INSTANCE: lazy-zip list
+INSTANCE: lazy-while list
+INSTANCE: lazy-until list
+INSTANCE: lazy-filter list
--- /dev/null
+<html>
+ <head>
+ <title>Lazy Evaluation</title>
+ <link rel="stylesheet" type="text/css" href="style.css">
+ </head>
+ <body>
+ <h1>Lazy Evaluation</h1>
+<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
+ ability to describe infinite structures, and to delay execution of
+ expressions until they are actually used.</p>
+<p>Lazy lists, like normal lists, are composed of a head and tail. In
+ a lazy list the head and tail are something called a 'promise'.
+ To convert a
+ 'promise' into its actual value a word called 'force' is used. To
+ convert a value into a 'promise' the word to use is 'delay'.</p>
+<table border="1">
+<tr><td><a href="#delay">delay</a></td></tr>
+<tr><td><a href="#force">force</a></td></tr>
+</table>
+
+<p>Many of the lazy list words are named similar to the standard list
+ words but with an 'l' suffixed to it. Here are the commonly used
+ words and their equivalent list operation:</p>
+<table border="1">
+<tr><th>Lazy List</th><th>Normal List</th></tr>
+<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
+<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
+<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
+<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
+<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
+<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
+<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
+<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
+<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
+<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
+<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
+<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
+</table>
+<p>A few additional words specific to lazy lists are:</p>
+<table border="1">
+<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
+number of items from the lazy list.</td></tr>
+<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
+concatenate them together in a lazy manner, returning a single lazy
+list.</td></tr>
+<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
+that contains the same elements as the normal list.</td></tr>
+</table>
+<h2>Reference</h2>
+<!-- delay description -->
+<a name="delay">
+<h3>delay ( quot -- <promise> )</h3>
+<p>'delay' is used to convert a value or expression into a promise.
+ The word 'force' is used to convert that promise back to its
+ value, or to force evaluation of the expression to return a value.
+</p>
+<p>The value on the stack that 'delay' expects must be quoted. This is
+ a requirement to prevent it from being evaluated.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- force description -->
+<a name="force">
+<h3>force ( <promise> -- value )</h3>
+<p>'force' will evaluate a promises original expression
+ and leave the value of that expression on the stack.
+</p>
+<p>A promise can be forced multiple times but the expression
+ is only evaluated once. Future calls of 'force' on the promise
+ will returned the cached value of the original force. If the
+ expression contains side effects, such as i/o, then that i/o
+ will only occur on the first 'force'. See below for an example
+ (steps 3-5).
+</p>
+<p>If a promise is itself delayed, a force will evaluate all promises
+ until a value is returned. Due to this behaviour it is generally not
+ possible to delay a promise. The example below shows what happens
+ in this case.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+
+ #! Multiple forces on a promise returns cached value
+ ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
+ ( 4 ) dup <a href="#force">force</a> .
+ => hello
+ 42
+ ( 5 ) <a href="#force">force</a> .
+ => 42
+
+ #! Forcing a delayed promise cascades up to return
+ #! original value, rather than the promise.
+ ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
+ ( 7 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- lnil description -->
+<a name="lnil">
+<h3>lnil ( -- lcons )</h3>
+<p>Returns a value representing the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> .
+ => << promise [ ] [ [ ] ] t [ ] >>
+</pre>
+
+<!-- lnil description -->
+<a name="lnilp">
+<h3>lnil? ( lcons -- bool )</h3>
+<p>Returns true if the given lazy cons is the value representing
+ the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
+ => [ ]
+ ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+</pre>
+
+<!-- lcons description -->
+<a name="lcons">
+<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
+<p>Provides the same effect as 'cons' does for normal lists.
+ Both values provided must be promises (ie. expressions that have
+ had <a href="#delay">delay</a> called on them).
+</p>
+<p>As the car and cdr passed on the stack are promises, they are not
+ evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
+ are called on the lazy cons.</p>
+<pre class="code">
+ ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => "car"
+ ( 3 ) dup <a href="#lcdr">lcdr</a> .
+ => "cdr"
+</pre>
+
+<!-- lunit description -->
+<a name="lunit">
+<h3>lunit ( value-promise -- llist )</h3>
+<p>Provides the same effect as 'unit' does for normal lists. It
+creates a lazy list where the first element is the value given.</p>
+<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
+ a promise and is not evaluated until the <a href="#lcar">lcar</a>
+ of the list is requested.</a>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => 42
+ ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 4 ) [ . ] <a href="#leach">leach</a>
+ => 42
+</pre>
+
+<!-- lcar description -->
+<a name="lcar">
+<h3>lcar ( lcons -- value )</h3>
+<p>Provides the same effect as 'car' does for normal lists. It
+returns the first element in a lazy cons cell. This will force
+the evaluation of that element.</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcar">lcar</a> .
+ => 42
+</pre>
+
+<!-- lcdr description -->
+<a name="lcdr">
+<h3>lcdr ( lcons -- value )</h3>
+<p>Provides the same effect as 'cdr' does for normal lists. It
+returns the second element in a lazy cons cell and forces it. This
+causes that element to be evaluated immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> .
+ => 11
+</pre>
+
+<pre class="code">
+ ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 6
+ ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 7
+ ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 8
+</pre>
+
+<!-- lnth description -->
+<a name="lnth">
+<h3>lnth ( n llist -- value )</h3>
+<p>Provides the same effect as 'nth' does for normal lists. It
+returns the nth value in the lazy list. It causes all the values up to
+'n' to be evaluated.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) 5 swap <a href="#lnth">lnth</a> .
+ => 6
+</pre>
+
+<!-- luncons description -->
+<a name="luncons">
+<h3>luncons ( lcons -- car cdr )</h3>
+<p>Provides the same effect as 'uncons' does for normal lists. It
+returns the car and cdr of the lazy list.</p>
+<pre class="code">
+ ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#luncons">luncons</a> . .
+ => 6
+ 5
+</pre>
+
+<!-- lmap description -->
+<a name="lmap">
+<h3>lmap ( llist quot -- llist )</h3>
+<p>Lazily maps over a lazy list applying the quotation to each element.
+A new lazy list is returned which contains the results of the
+quotation.</p>
+<p>When intially called nothing in the original lazy list is
+evaluated. Only when <a href="#lcar">lcar</a> is called will the item
+in the list be evaluated and applied to the quotation. Ditto with <a
+href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
+ => < infinite list of numbers incrementing by 2 >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 4 6 8 10 ]
+</pre>
+
+<!-- lsubset description -->
+<a name="lsubset">
+<h3>lsubset ( llist pred -- llist )</h3>
+<p>Provides the same effect as 'subset' does for normal lists. It
+lazily iterates over a lazy list applying the predicate quotation to each
+element. If that quotation returns true, the element will be included
+in the resulting lazy list. If it is false, the element will be skipped.
+A new lazy list is returned which contains all elements where the
+predicate returned true.</p>
+<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
+will occur. A lazy list is returned that when values are retrieved
+from in then items are evaluated and checked against the predicate.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
+ => < infinite list of prime numbers >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 3 5 7 11 ]
+</pre>
+
+<!-- leach description -->
+<a name="leach">
+<h3>leach ( llist quot -- )</h3>
+<p>Provides the same effect as 'each' does for normal lists. It
+lazily iterates over a lazy list applying the quotation to each
+element. If this operation is applied to an infinite list it will
+never return unless the quotation escapes out by calling a continuation.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
+ => < infinite list of odd numbers >
+ ( 3 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 3
+ 5
+ 7
+ ... for ever ...
+</pre>
+
+<!-- ltake description -->
+<a name="ltake">
+<h3>ltake ( n llist -- llist )</h3>
+<p>Iterates over the lazy list 'n' times, appending each element to a
+lazy list. This provides a convenient way of getting elements out of
+an infinite lazy list.</p>
+<pre class="code">
+ ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
+ ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 1 1 1 1 1 ]
+</pre>
+
+<!-- lappend description -->
+<a name="lappend">
+<h3>lappend ( llist1 llist2 -- llist )</h3>
+<p>Lazily appends two lists together. The actual appending is done
+lazily on iteration rather than immediately so it works very fast no
+matter how large the list.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+</pre>
+
+<!-- lappend* description -->
+<a name="lappendstar">
+<h3>lappend* ( llists -- llist )</h3>
+<p>Given a lazy list of lazy lists, concatenate them together in a
+lazy fashion. The actual appending is done lazily on iteration rather
+than immediately so it works very fast no matter how large the lists.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
+ ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
+ ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
+ ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
+ ( 5 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+</pre>
+
+<!-- list>llist description -->
+<a name="list2llist">
+<h3>list>llist ( list -- llist )</h3>
+<p>Converts a normal list into a lazy list. This is done lazily so the
+initial list is not iterated through immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+</pre>
+
+<p class="footer">
+News and updates to this software can be obtained from the authors
+weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
+<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
+</body> </html>
--- /dev/null
+Lazy lists
--- /dev/null
+extensions
+collections
--- /dev/null
+! 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 { "cons" "An empty cons" } }
+{ $description "Returns a representation of an empty list" } ;
+
+HELP: nil?
+{ $values { "cons" "a cons object" } { "?" "a boolean" } }
+{ $description "Return true if the cons object is the nil cons." } ;
+
+HELP: list? ( object -- ? )
+{ $values { "object" "an object" } { "?" "a boolean" } }
+{ $description "Returns true if the object conforms to the list protocol." } ;
+
+{ 1list 2list 3list } related-words
+
+HELP: 1list
+{ $values { "obj" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 1 element." } ;
+
+HELP: 2list
+{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 2 elements." } ;
+
+HELP: 3list
+{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 3 elements." } ;
+
+HELP: 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 { "array" "an array object" } { "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." } ;
+
--- /dev/null
+! 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
--- /dev/null
+! 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? ( cons -- ? )
+
+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 ( -- +nil+ ) +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 ident quot -- result ) swapd leach ; inline
+
+: foldr ( list ident quot -- result )
+ pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
+ [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
+ call
+ ] if ; inline
+
+: llength ( list -- n )
+ 0 [ drop 1+ ] foldl ;
+
+: lreverse ( list -- newlist )
+ nil [ swap cons ] foldl ;
+
+: seq>list ( seq -- list )
+ <reversed> nil [ swap cons ] reduce ;
+
+: same? ( obj1 obj2 -- ? )
+ [ class ] bi@ = ;
+
+: seq>cons ( seq -- cons )
+ [ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
+
+: (lmap>array) ( acc cons quot -- newcons )
+ over nil? [ 2drop ]
+ [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline
+
+: lmap>array ( cons quot -- newcons )
+ { } -rot (lmap>array) ; inline
+
+: lmap-as ( cons quot exemplar -- seq )
+ [ lmap>array ] dip like ;
+
+: cons>seq ( cons -- array )
+ [ dup cons? [ cons>seq ] when ] lmap>array ;
+
+: list>seq ( list -- array )
+ [ ] lmap>array ;
+
+: traverse ( list pred quot -- result )
+ [ 2over call [ tuck [ call ] 2dip ] when
+ pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ;
+
+INSTANCE: cons list
\ No newline at end of file
--- /dev/null
+Implementation of lisp-style linked lists
--- /dev/null
+cons
+lists
+sequences
! 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
! 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
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math math.primes namespaces sequences ;
+USING: arrays kernel lists math math.primes namespaces sequences ;
IN: math.primes.factors
<PRIVATE
dup empty? [ drop ] [ first , ] if ;
: (factors) ( quot list n -- )
- dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
+ dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
: (decompose) ( n quot -- seq )
[ lprimes rot (factors) ] { } make ;
-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
! 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
-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
! 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
M: list monad-of drop list-monad ;
-M: list >>= '[ , _ lmap lconcat ] ;
+M: list >>= '[ , _ lazy-map lconcat ] ;
! State
SINGLETON: state-monad
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
+USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
IN: morse
<PRIVATE
swap >>format
swap >>bytes ;
-:: render ( gadget -- )
+GENERIC: render* ( texture-gadget -- )
+
+M:: texture-gadget render* ( gadget -- )
GL_ENABLE_BIT [
GL_TEXTURE_2D glEnable
GL_TEXTURE_2D gadget tex>> glBindTexture
] with-translation ;
M: texture-gadget graft* ( gadget -- )
- gen-texture >>tex [ render ]
- [ f >>bytes f >>format drop ] bi ;
+ gen-texture >>tex [ render* ]
+ [ f >>bytes drop ] bi ;
M: texture-gadget ungraft* ( gadget -- )
tex>> delete-texture ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
-continuations destructors debugger inspector
+continuations destructors debugger inspector splitting
locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
[ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
+: common-names-match? ( expected actual -- ? )
+ [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
+
: check-common-name ( host ssl-handle -- )
- SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
+ SSL_get_peer_certificate common-name
+ 2dup common-names-match?
[ 2drop ] [ common-name-verify-error ] if ;
M: openssl check-certificate ( host ssl -- )
! pangocairo bindings, from pango/pangocairo.h
USING: cairo.ffi alien.c-types math
alien.syntax system combinators alien
+memoize
arrays pango pango.fonts ;
IN: pango.cairo
0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
[ *int ] bi@ ;
+MEMO: dummy-cairo ( -- cr )
+ CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ;
+
: dummy-pango ( quot -- )
- >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
- r> [ with-pango ] curry with-cairo-from-surface ; inline
+ >r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline
: layout-size ( quot -- dim )
[ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
: layout-text ( str -- )
layout swap -1 pango_layout_set_text ;
+: show-layout ( -- )
+ cr layout pango_cairo_show_layout ;
+
: families ( -- families )
pango_cairo_font_map_get_default list-families ;
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: pango.cairo cairo cairo.ffi cairo.gadgets
+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 ;
IN: pango.cairo.gadgets
-: (pango-gadget) ( setup show -- gadget )
- [ drop layout-size ]
- [ compose [ with-pango ] curry <cairo-gadget> ] 2bi ;
-
-: <pango-gadget> ( quot -- gadget )
- [ cr layout pango_cairo_show_layout ] (pango-gadget) ;
-
-USING: prettyprint sequences ui.gadgets.panes
-threads io.backend io.encodings.utf8 io.files ;
-: hello-pango ( -- )
- 50 [ 6 + ] map [
- "Sans " swap unparse append
- [
- cr 0 1 0.2 0.6 cairo_set_source_rgba
- layout-font "今日は、 Pango!" layout-text
- ] curry
- <pango-gadget> gadget. yield
- ] each
- [
- "resource:extra/pango/cairo/gadgets/gadgets.factor"
- normalize-path utf8 file-contents layout-text
- ] <pango-gadget> gadget. ;
-
-MAIN: hello-pango
+SYMBOL: textures
+SYMBOL: dims
+SYMBOL: refcounts
+
+: init-cache ( symbol -- )
+ dup get [ drop ] [ H{ } clone swap set-global ] if ;
+
+textures init-cache
+dims init-cache
+refcounts init-cache
+
+TUPLE: pango-gadget < cairo-gadget text font ;
+
+: cache-key ( gadget -- key )
+ [ font>> ] [ text>> ] bi 2array ;
+
+: refcount-change ( gadget quot -- )
+ >r cache-key refcounts get
+ [ [ 0 ] unless* ] r> compose change-at ;
+
+: <pango-gadget> ( font text -- gadget )
+ pango-gadget construct-gadget
+ swap >>text
+ swap >>font ;
+
+: setup-layout ( {font,text} -- quot )
+ first2 '[ , layout-font , layout-text ] ; inline
+
+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" <pango-gadget> gadget. ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: prettyprint sequences ui.gadgets.panes
+pango.cairo.gadgets math kernel cairo cairo.ffi
+pango.cairo tools.time namespaces assocs
+threads io.backend io.encodings.utf8 io.files ;
+
+IN: pango.cairo.samples
+
+: hello-pango ( -- )
+ "monospace 10" "resource:extra/pango/cairo/gadgets/gadgets.factor"
+ normalize-path utf8 file-contents
+ <pango-gadget> gadget. ;
+
+: time-pango ( -- )
+ [ hello-pango ] time ;
+
+! clear the caches, for testing.
+: clear-pango ( -- )
+ dims get clear-assoc
+ textures get clear-assoc ;
+
+MAIN: time-pango
"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" } } ;
! 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
! 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
>r parse-result-parsed r>
[ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result>
- ] 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
#! 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
-rot parse [
[ parse-result-parsed swap call ] keep
parse-result-unparsed <parse-result>
- ] lmap-with ;
+ ] lazy-map-with ;
TUPLE: some-parser p1 ;
"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
"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" } }
"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
"'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
! 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
--- /dev/null
+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 "" ;
! 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
! 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
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
-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 ;
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
- <feed xmlns="http://www.w3.org/2005/Atom">
- <title type="text">dive into mark</title>
- <subtitle type="html">
- A <em>lot</em> of effort
- went into making this effortless
- </subtitle>
- <updated>2005-07-31T12:29:29Z</updated>
- <id>tag:example.org,2003:3</id>
- <link rel="alternate" type="text/html"
- hreflang="en" href="http://example.org/"/>
- <link rel="self" type="application/atom+xml"
- href="http://example.org/feed.atom"/>
- <rights>Copyright (c) 2003, Mark Pilgrim</rights>
- <generator uri="http://www.example.com/" version="1.0">
- Example Toolkit
- </generator>
- <entry>
- <title>Atom draft-07 snapshot</title>
- <link rel="alternate" type="text/html"
- href="http://example.org/2005/04/02/atom"/>
- <link rel="enclosure" type="audio/mpeg" length="1337"
- href="http://example.org/audio/ph34r_my_podcast.mp3"/>
- <id>tag:example.org,2003:3.2397</id>
- <updated>2005-07-31T12:29:29Z</updated>
- <published>2003-12-13T08:29:29-04:00</published>
- <author>
- <name>Mark Pilgrim</name>
- <uri>http://example.org/</uri>
- <email>f8dy@example.com</email>
- </author>
- <contributor>
- <name>Sam Ruby</name>
- </contributor>
- <contributor>
- <name>Joe Gregorio</name>
- </contributor>
- <content type="xhtml" xml:lang="en"
- xml:base="http://diveintomark.org/">
- <div xmlns="http://www.w3.org/1999/xhtml">
- <p><i>[Update: The Atom draft is finished.]</i></p>
- </div>
- </content>
- </entry>
- </feed>
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-This library is a simple RSS2 parser and RSS reader web
-application. To run the web application you'll need to make sure you
-have the sqlite library working. This can be tested with
-
- "contrib/sqlite" require
- "contrib/sqlite" test-module
-
-Remember that to use "sqlite" you need to have done the following
-somewhere:
-
- USE: alien
- "sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
-
-Replacing "libsqlite3.so" with the path to the sqlite shared library
-or DLL. I put this in my ~/.factor-rc.
-
-The RSS reader web application creates a database file called
-'rss-reader.db' in the same directory as the Factor executable when
-first started. This database contains all the feed information.
-
-To load the web application use:
-
- "contrib/rss" require
-
-Fire up the web server and navigate to the URL:
-
- http://localhost:8888/responder/maintain-feeds
-
-Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
-update the sqlite database with the feed contains. Use 'Database' to
-view the entries from the database for that feed.
-
+++ /dev/null
-USING: rss io kernel io.files tools.test io.encodings.utf8
-calendar ;
-IN: rss.tests
-
-: load-news-file ( filename -- feed )
- #! Load an news syndication file and process it, returning
- #! it as an feed tuple.
- utf8 file-contents read-feed ;
-
-[ T{
- feed
- f
- "Meerkat"
- "http://meerkat.oreillynet.com"
- {
- T{
- entry
- f
- "XML: A Disruptive Technology"
- "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
-[ T{
- feed
- f
- "dive into mark"
- "http://example.org/"
- {
- T{
- entry
- f
- "Atom draft-07 snapshot"
- "http://example.org/2005/04/02/atom"
- "\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
-
- T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
- }
- }
-} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test
+++ /dev/null
-! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml.utilities kernel assocs xml.generator math.order
- strings sequences xml.data xml.writer
- io.streams.string combinators xml xml.entities io.files io
- http.client namespaces xml.generator hashtables
- calendar.format accessors continuations urls ;
-IN: rss
-
-: any-tag-named ( tag names -- tag-inside )
- f -rot [ tag-named nip dup ] with find 2drop ;
-
-TUPLE: feed title link entries ;
-
-C: <feed> feed
-
-TUPLE: entry title link description pub-date ;
-
-C: <entry> entry
-
-: try-parsing-timestamp ( string -- timestamp )
- [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
-
-: rss1.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ]
- [ "description" tag-named children>string ]
- [
- f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named dup [ children>string try-parsing-timestamp ] when
- ]
- } cleave <entry> ;
-
-: rss1.0 ( xml -- feed )
- [
- "channel" tag-named
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ] bi
- ] [ "item" tags-named [ rss1.0-entry ] map ] bi
- <feed> ;
-
-: rss2.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ { "link" "guid" } any-tag-named children>string ]
- [ "description" tag-named children>string ]
- [
- { "date" "pubDate" } any-tag-named
- children>string try-parsing-timestamp
- ]
- } cleave <entry> ;
-
-: rss2.0 ( xml -- feed )
- "channel" tag-named
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ]
- [ "item" tags-named [ rss2.0-entry ] map ]
- tri <feed> ;
-
-: atom1.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ "link" tag-named "href" swap at ]
- [
- { "content" "summary" } any-tag-named
- dup tag-children [ string? not ] contains?
- [ tag-children [ write-chunk ] with-string-writer ]
- [ children>string ] if
- ]
- [
- { "published" "updated" "issued" "modified" }
- any-tag-named children>string try-parsing-timestamp
- ]
- } cleave <entry> ;
-
-: atom1.0 ( xml -- feed )
- [ "title" tag-named children>string ]
- [ "link" tag-named "href" swap at ]
- [ "entry" tags-named [ atom1.0-entry ] map ]
- tri <feed> ;
-
-: xml>feed ( xml -- feed )
- dup name-tag {
- { "RDF" [ rss1.0 ] }
- { "rss" [ rss2.0 ] }
- { "feed" [ atom1.0 ] }
- } case ;
-
-: read-feed ( string -- feed )
- [ string>xml xml>feed ] with-html-entities ;
-
-: download-feed ( url -- feed )
- #! Retrieve an news syndication file, return as a feed tuple.
- http-get read-feed ;
-
-! Atom generation
-: simple-tag, ( content name -- )
- [ , ] tag, ;
-
-: simple-tag*, ( content name attrs -- )
- [ , ] tag*, ;
-
-: entry, ( entry -- )
- "entry" [
- dup title>> "title" { { "type" "html" } } simple-tag*,
- "link" over link>> dup url? [ url>string ] when "href" associate contained*,
- dup pub-date>> timestamp>rfc3339 "published" simple-tag,
- description>> [ "content" { { "type" "html" } } simple-tag*, ] when*
- ] tag, ;
-
-: feed>xml ( feed -- xml )
- "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
- dup title>> "title" simple-tag,
- "link" over link>> dup url? [ url>string ] when "href" associate contained*,
- entries>> [ entry, ] each
- ] make-xml* ;
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
-
-<rdf:RDF
- xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
- xmlns:dc="http://purl.org/dc/elements/1.1/"
- xmlns:sy="http://purl.org/rss/1.0/modules/syndication/"
- xmlns:co="http://purl.org/rss/1.0/modules/company/"
- xmlns:ti="http://purl.org/rss/1.0/modules/textinput/"
- xmlns="http://purl.org/rss/1.0/"
->
-
- <channel rdf:about="http://meerkat.oreillynet.com/?_fl=rss1.0">
- <title>Meerkat</title>
- <link>http://meerkat.oreillynet.com</link>
- <description>Meerkat: An Open Wire Service</description>
- <dc:publisher>The O'Reilly Network</dc:publisher>
- <dc:creator>Rael Dornfest (mailto:rael@oreilly.com)</dc:creator>
- <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
- <dc:date>2000-01-01T12:00+00:00</dc:date>
- <sy:updatePeriod>hourly</sy:updatePeriod>
- <sy:updateFrequency>2</sy:updateFrequency>
- <sy:updateBase>2000-01-01T12:00+00:00</sy:updateBase>
-
- <image rdf:resource="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg" />
-
- <items>
- <rdf:Seq>
- <rdf:li resource="http://c.moreover.com/click/here.pl?r123" />
- </rdf:Seq>
- </items>
-
- <textinput rdf:resource="http://meerkat.oreillynet.com" />
-
- </channel>
-
- <image rdf:about="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg">
- <title>Meerkat Powered!</title>
- <url>http://meerkat.oreillynet.com/icons/meerkat-powered.jpg</url>
- <link>http://meerkat.oreillynet.com</link>
- </image>
-
- <item rdf:about="http://c.moreover.com/click/here.pl?r123">
- <title>XML: A Disruptive Technology</title>
- <link>http://c.moreover.com/click/here.pl?r123</link>
- <dc:description>
- XML is placing increasingly heavy loads on the existing technical
- infrastructure of the Internet.
- </dc:description>
- <dc:publisher>The O'Reilly Network</dc:publisher>
- <dc:creator>Simon St.Laurent (mailto:simonstl@simonstl.com)</dc:creator>
- <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
- <dc:subject>XML</dc:subject>
- <co:name>XML.com</co:name>
- <co:market>NASDAQ</co:market>
- <co:symbol>XML</co:symbol>
- </item>
-
- <textinput rdf:about="http://meerkat.oreillynet.com">
- <title>Search Meerkat</title>
- <description>Search Meerkat's RSS Database...</description>
- <name>s</name>
- <link>http://meerkat.oreillynet.com/</link>
- <ti:function>search</ti:function>
- <ti:inputType>regex</ti:inputType>
- </textinput>
-
-</rdf:RDF>
+++ /dev/null
-RSS 1.0, 2.0 and Atom feed parser
--- /dev/null
+Daniel Ehrenberg
+Chris Double
+Slava Pestov
--- /dev/null
+This library is a simple RSS2 parser and RSS reader web
+application. To run the web application you'll need to make sure you
+have the sqlite library working. This can be tested with
+
+ "contrib/sqlite" require
+ "contrib/sqlite" test-module
+
+Remember that to use "sqlite" you need to have done the following
+somewhere:
+
+ USE: alien
+ "sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
+
+Replacing "libsqlite3.so" with the path to the sqlite shared library
+or DLL. I put this in my ~/.factor-rc.
+
+The RSS reader web application creates a database file called
+'rss-reader.db' in the same directory as the Factor executable when
+first started. This database contains all the feed information.
+
+To load the web application use:
+
+ "contrib/rss" require
+
+Fire up the web server and navigate to the URL:
+
+ http://localhost:8888/responder/maintain-feeds
+
+Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
+update the sqlite database with the feed contains. Use 'Database' to
+view the entries from the database for that feed.
+
--- /dev/null
+RSS 1.0, 2.0 and Atom feed parser
--- /dev/null
+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
+ #! it as an feed tuple.
+ utf8 file-contents read-feed ;
+
+[ T{
+ feed
+ f
+ "Meerkat"
+ URL" http://meerkat.oreillynet.com"
+ {
+ T{
+ entry
+ f
+ "XML: A Disruptive Technology"
+ 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/syndication/test/rss1.xml" load-news-file ] unit-test
+[ T{
+ feed
+ f
+ "dive into mark"
+ URL" http://example.org/"
+ {
+ T{
+ entry
+ f
+ "Atom draft-07 snapshot"
+ URL" http://example.org/2005/04/02/atom"
+ "\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
+
+ T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
+ }
+ }
+} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test
--- /dev/null
+! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
+! Portions copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml.utilities kernel assocs xml.generator math.order
+ strings sequences xml.data xml.writer
+ io.streams.string combinators xml xml.entities io.files io
+ http.client namespaces xml.generator hashtables
+ calendar.format accessors continuations urls present ;
+IN: syndication
+
+: any-tag-named ( tag names -- tag-inside )
+ f -rot [ tag-named nip dup ] with find 2drop ;
+
+TUPLE: feed title url entries ;
+
+: <feed> ( -- feed ) feed new ;
+
+TUPLE: entry title url description date ;
+
+: set-entries ( feed entries -- feed )
+ [ dup url>> ] dip
+ [ [ derive-url ] change-url ] with map
+ >>entries ;
+
+: <entry> ( -- entry ) entry new ;
+
+: try-parsing-timestamp ( string -- timestamp )
+ [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
+
+: rss1.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ]
+ [ "description" tag-named children>string >>description ]
+ [
+ f "date" "http://purl.org/dc/elements/1.1/" <name>
+ tag-named dup [ children>string try-parsing-timestamp ] when
+ >>date
+ ]
+ } cleave ;
+
+: rss1.0 ( xml -- feed )
+ feed new
+ swap [
+ "channel" tag-named
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ] bi
+ ] [ "item" tags-named [ rss1.0-entry ] map set-entries ] bi ;
+
+: rss2.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ { "link" "guid" } any-tag-named children>string >url >>url ]
+ [ "description" tag-named children>string >>description ]
+ [
+ { "date" "pubDate" } any-tag-named
+ children>string try-parsing-timestamp >>date
+ ]
+ } cleave ;
+
+: rss2.0 ( xml -- feed )
+ feed new
+ swap
+ "channel" tag-named
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ]
+ [ "item" tags-named [ rss2.0-entry ] map set-entries ]
+ tri ;
+
+: atom1.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named "href" swap at >url >>url ]
+ [
+ { "content" "summary" } any-tag-named
+ dup tag-children [ string? not ] contains?
+ [ tag-children [ write-chunk ] with-string-writer ]
+ [ children>string ] if >>description
+ ]
+ [
+ { "published" "updated" "issued" "modified" }
+ any-tag-named children>string try-parsing-timestamp
+ >>date
+ ]
+ } cleave ;
+
+: atom1.0 ( xml -- feed )
+ feed new
+ swap
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named "href" swap at >url >>url ]
+ [ "entry" tags-named [ atom1.0-entry ] map set-entries ]
+ tri ;
+
+: xml>feed ( xml -- feed )
+ dup name-tag {
+ { "RDF" [ rss1.0 ] }
+ { "rss" [ rss2.0 ] }
+ { "feed" [ atom1.0 ] }
+ } case ;
+
+: read-feed ( string -- feed )
+ [ string>xml xml>feed ] with-html-entities ;
+
+: download-feed ( url -- feed )
+ #! Retrieve an news syndication file, return as a feed tuple.
+ http-get read-feed ;
+
+! Atom generation
+: simple-tag, ( content name -- )
+ [ , ] tag, ;
+
+: simple-tag*, ( content name attrs -- )
+ [ , ] tag*, ;
+
+: entry, ( entry -- )
+ "entry" [
+ {
+ [ title>> "title" { { "type" "html" } } simple-tag*, ]
+ [ url>> present "href" associate "link" swap contained*, ]
+ [ date>> timestamp>rfc3339 "published" simple-tag, ]
+ [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ]
+ } cleave
+ ] tag, ;
+
+: feed>xml ( feed -- xml )
+ "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
+ [ title>> "title" simple-tag, ]
+ [ url>> present "href" associate "link" swap contained*, ]
+ [ entries>> [ entry, ] each ]
+ tri
+ ] make-xml* ;
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+ <feed xmlns="http://www.w3.org/2005/Atom">
+ <title type="text">dive into mark</title>
+ <subtitle type="html">
+ A <em>lot</em> of effort
+ went into making this effortless
+ </subtitle>
+ <updated>2005-07-31T12:29:29Z</updated>
+ <id>tag:example.org,2003:3</id>
+ <link rel="alternate" type="text/html"
+ hreflang="en" href="http://example.org/"/>
+ <link rel="self" type="application/atom+xml"
+ href="http://example.org/feed.atom"/>
+ <rights>Copyright (c) 2003, Mark Pilgrim</rights>
+ <generator uri="http://www.example.com/" version="1.0">
+ Example Toolkit
+ </generator>
+ <entry>
+ <title>Atom draft-07 snapshot</title>
+ <link rel="alternate" type="text/html"
+ href="http://example.org/2005/04/02/atom"/>
+ <link rel="enclosure" type="audio/mpeg" length="1337"
+ href="http://example.org/audio/ph34r_my_podcast.mp3"/>
+ <id>tag:example.org,2003:3.2397</id>
+ <updated>2005-07-31T12:29:29Z</updated>
+ <published>2003-12-13T08:29:29-04:00</published>
+ <author>
+ <name>Mark Pilgrim</name>
+ <uri>http://example.org/</uri>
+ <email>f8dy@example.com</email>
+ </author>
+ <contributor>
+ <name>Sam Ruby</name>
+ </contributor>
+ <contributor>
+ <name>Joe Gregorio</name>
+ </contributor>
+ <content type="xhtml" xml:lang="en"
+ xml:base="http://diveintomark.org/">
+ <div xmlns="http://www.w3.org/1999/xhtml">
+ <p><i>[Update: The Atom draft is finished.]</i></p>
+ </div>
+ </content>
+ </entry>
+ </feed>
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+
+<rdf:RDF
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:dc="http://purl.org/dc/elements/1.1/"
+ xmlns:sy="http://purl.org/rss/1.0/modules/syndication/"
+ xmlns:co="http://purl.org/rss/1.0/modules/company/"
+ xmlns:ti="http://purl.org/rss/1.0/modules/textinput/"
+ xmlns="http://purl.org/rss/1.0/"
+>
+
+ <channel rdf:about="http://meerkat.oreillynet.com/?_fl=rss1.0">
+ <title>Meerkat</title>
+ <link>http://meerkat.oreillynet.com</link>
+ <description>Meerkat: An Open Wire Service</description>
+ <dc:publisher>The O'Reilly Network</dc:publisher>
+ <dc:creator>Rael Dornfest (mailto:rael@oreilly.com)</dc:creator>
+ <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
+ <dc:date>2000-01-01T12:00+00:00</dc:date>
+ <sy:updatePeriod>hourly</sy:updatePeriod>
+ <sy:updateFrequency>2</sy:updateFrequency>
+ <sy:updateBase>2000-01-01T12:00+00:00</sy:updateBase>
+
+ <image rdf:resource="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg" />
+
+ <items>
+ <rdf:Seq>
+ <rdf:li resource="http://c.moreover.com/click/here.pl?r123" />
+ </rdf:Seq>
+ </items>
+
+ <textinput rdf:resource="http://meerkat.oreillynet.com" />
+
+ </channel>
+
+ <image rdf:about="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg">
+ <title>Meerkat Powered!</title>
+ <url>http://meerkat.oreillynet.com/icons/meerkat-powered.jpg</url>
+ <link>http://meerkat.oreillynet.com</link>
+ </image>
+
+ <item rdf:about="http://c.moreover.com/click/here.pl?r123">
+ <title>XML: A Disruptive Technology</title>
+ <link>http://c.moreover.com/click/here.pl?r123</link>
+ <dc:description>
+ XML is placing increasingly heavy loads on the existing technical
+ infrastructure of the Internet.
+ </dc:description>
+ <dc:publisher>The O'Reilly Network</dc:publisher>
+ <dc:creator>Simon St.Laurent (mailto:simonstl@simonstl.com)</dc:creator>
+ <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
+ <dc:subject>XML</dc:subject>
+ <co:name>XML.com</co:name>
+ <co:market>NASDAQ</co:market>
+ <co:symbol>XML</co:symbol>
+ </item>
+
+ <textinput rdf:about="http://meerkat.oreillynet.com">
+ <title>Search Meerkat</title>
+ <description>Search Meerkat's RSS Database...</description>
+ <name>s</name>
+ <link>http://meerkat.oreillynet.com/</link>
+ <ti:function>search</ti:function>
+ <ti:inputType>regex</ti:inputType>
+ </textinput>
+
+</rdf:RDF>
! 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? ;
! 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
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
] 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
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 -- ? )
{ [ dup letter? ] [ t ] }
{ [ dup LETTER? ] [ t ] }
{ [ dup digit? ] [ t ] }
- { [ dup "/_-.:" member? ] [ t ] }
+ { [ dup "/_-." member? ] [ t ] }
[ f ]
} cond nip ; foldable
+<PRIVATE
+
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+PRIVATE>
+
: url-encode ( str -- str )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
+<PRIVATE
+
: url-decode-hex ( index str -- )
2dup length 2 - >= [
2drop
] if url-decode-iter
] if ;
+PRIVATE>
+
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make utf8 decode ;
+<PRIVATE
+
: add-query-param ( value key assoc -- )
[
at [
] when*
] 2keep set-at ;
+PRIVATE>
+
: query>assoc ( query -- assoc )
dup [
"&" split H{ } clone [
: assoc>query ( hash -- str )
[
- {
- { [ dup number? ] [ number>string 1array ] }
- { [ dup string? ] [ 1array ] }
- { [ dup sequence? ] [ ] }
- } cond
+ dup array? [ [ present ] map ] [ present 1array ] if
] assoc-map
[
[
] when
] bi* ;
+<PRIVATE
+
: parse-host-part ( url protocol rest -- url string' )
[ >>protocol ] [
"//" ?head [ "Invalid URL" throw ] unless
] [ "/" prepend ] bi*
] bi* ;
+PRIVATE>
+
GENERIC: >url ( obj -- url )
M: url >url ;
]
[ url-decode >>anchor ] bi* ;
+<PRIVATE
+
: unparse-username-password ( url -- )
dup username>> dup [
% password>> [ ":" % % ] when* "@" %
[ path>> "/" head? [ "/" % ] unless ]
} cleave ;
-: url>string ( url -- string )
+M: url present
[
{
[ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
[ [ "/" last-split1 drop "/" ] dip 3append ]
} cond ;
+PRIVATE>
+
: derive-url ( base url -- url' )
[ clone dup ] dip
2dup [ path>> ] bi@ url-append-path
! 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 ;
http.server
http.server.dispatchers
furnace.db
-furnace.flows
+furnace.asides
+furnace.flash
furnace.sessions
furnace.auth.login
furnace.auth.providers.db
webapps.planet
webapps.todo
webapps.wiki
+webapps.wee-url
webapps.user-admin ;
IN: webapps.factor-website
init-articles-table
init-revisions-table
+
+ init-short-url-table
] with-db ;
TUPLE: factor-website < dispatcher ;
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
<wiki> "wiki" add-responder
+ <wee-url> "wee-url" add-responder
<user-admin> "user-admin" add-responder
<login>
users-in-db >>users
allow-edit-profile
<boilerplate>
{ factor-website "page" } >>template
- <flows>
- <sessions>
+ <asides> <flash-scopes> <sessions>
test-db <db-persistence> ;
: init-factor-website ( -- )
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="This paste" t:href="$pastebin/paste.atom" t:query="id" />
+ <t:atom t:href="$pastebin/paste.atom" t:query="id">
+ Paste: <t:label t:name="summary" />
+ </t:atom>
<t:title>Paste: <t:label t:name="summary" /></t:title>
<pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
- <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
+ <t:button t:action="$pastebin/delete-annotation" t:for="id" class="link-button link">Delete Annotation</t:button>
</t:bind-each>
<h2>New Annotation</h2>
- <t:form t:action="$pastebin/new-annotation" t:for="id">
+ <t:form t:action="$pastebin/new-annotation" t:for="parent">
<table>
<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
- <tr><th class="field-label big-field-label">Body:</th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
+ <tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
<tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
<tr>
<td></td>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Pastebin" t:href="$pastebin/list.atom" />
+ <t:atom t:href="$pastebin/list.atom">Pastebin</t:atom>
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
! 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
furnace.auth
furnace.auth.login
furnace.boilerplate
-furnace.rss ;
+furnace.syndication ;
IN: webapps.pastebin
TUPLE: pastebin < dispatcher ;
{ "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
swap >>id
swap >>parent ;
-: fetch-annotations ( paste -- paste )
- dup annotations>> [
- dup id>> f <annotation> select-tuples >>annotations
- ] unless ;
-
: paste ( id -- paste )
- <paste> select-tuple fetch-annotations ;
+ [ <paste> select-tuple ]
+ [ f <annotation> select-tuples ]
+ bi >>annotations ;
! ! !
! LINKS, ETC
! ! !
-: pastebin-link ( -- url )
+: pastebin-url ( -- url )
URL" $pastebin/list" ;
-GENERIC: entity-link ( entity -- url )
-
-: paste-link ( id -- url )
- <url>
- "$pastebin/paste" >>path
- swap "id" set-query-param ;
+: paste-url ( id -- url )
+ "$pastebin/paste" >url swap "id" set-query-param ;
-M: paste entity-link
- id>> paste-link ;
+M: paste entity-url
+ id>> paste-url ;
-: annotation-link ( parent id -- url )
- <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
[ pastes "pastes" set-value ] >>init
{ pastebin "pastebin" } >>template ;
-: pastebin-feed-entries ( seq -- entries )
- <reversed> 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 ;
-
: <pastebin-feed-action> ( -- action )
- <feed-action> [ pastebin-feed ] >>feed ;
+ <feed-action>
+ [ pastebin-url ] >>url
+ [ "Factor Pastebin" ] >>title
+ [ pastes <reversed> ] >>entries ;
! ! !
! PASTES
"id" value
"new-annotation" [
- "id" set-value
+ "parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
] nest-values
{ 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 ;
-
: <paste-feed-action> ( -- action )
<feed-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 <annotation> select-tuples ] >>entries ;
: validate-entity ( -- )
{
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
- [ id>> paste-link <redirect> ]
+ [ id>> paste-url <redirect> ]
tri
] >>submit ;
: <new-annotation-action> ( -- action )
<action>
[
- { { "id" [ v-integer ] } } validate-params
- "id" value paste-link <redirect>
- ] >>display
-
- [
- { { "id" [ v-integer ] } } validate-params
+ { { "parent" [ v-integer ] } } validate-params
validate-entity
] >>validate
[
- "
id" value f <annotation>
+ "
parent" value f <annotation>
[ deposit-entity-slots ]
[ insert-tuple ]
- [ entity-link <redirect> ]
+ [ entity-url <redirect> ]
tri
] >>submit ;
[
f "id" value <annotation> select-tuple
[ delete-tuples ]
- [ parent>> paste-link <redirect> ]
+ [ parent>> paste-url <redirect> ]
bi
] >>submit ;
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
- <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
+ <delete-paste-action> <protected>
+ "delete pastes" >>description
+ { can-delete-pastes? } >>capabilities "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
- <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
+ <delete-annotation-action> <protected>
+ "delete annotations" >>description
+ { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
</t:bind-each>
</ul>
- <p>
+ <div>
<t:a t:href="$planet-factor/admin/new-blog">Add Blog</t:a>
| <t:button t:action="$planet-factor/admin/update" class="link-button link">Update</t:button>
- </p>
+ </div>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <p class="news">
- <strong><t:view t:component="title" /></strong> <br/>
- <t:a value="link" class="more">Read More...</t:a>
- </p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h2 class="posting-title">
- <t:a t:value="link"><t:view t:component="title" /></t:a>
- </h2>
-
- <p class="posting-body">
- <t:view t:component="description" />
- </p>
-
- <p class="posting-date">
- <t:a t:value="link"><t:view t:component="pub-date" /></t:a>
- </p>
-
-</t:chloe>
<t:bind-each t:name="postings">
<p class="news">
- <strong><t:view t:component="title" /></strong> <br/>
+ <strong><t:label t:name="title" /></strong> <br/>
<t:a value="link" class="more">Read More...</t:a>
</p>
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
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
furnace.boilerplate
furnace.auth.login
furnace.auth
-furnace.rss ;
+furnace.syndication ;
IN: webapps.planet
TUPLE: planet-factor < dispatcher ;
{ "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 ;
: postings ( -- seq )
posting new select-tuples
- [ [ pub-date>> ] compare invert-comparison ] sort ;
+ [ [ date>> ] compare invert-comparison ] sort ;
: <edit-blogroll-action> ( -- action )
<page-action>
{ planet-factor "planet" } >>template ;
-: planet-feed ( -- feed )
- feed new
- "Planet Factor" >>title
- "http://planet.factorcode.org" >>link
- postings >>entries ;
-
: <planet-feed-action> ( -- action )
- <feed-action> [ planet-feed ] >>feed ;
+ <feed-action>
+ [ "Planet Factor" ] >>title
+ [ URL" $planet-factor" ] >>url
+ [ postings ] >>entries ;
:: <posting> ( 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>> ;
[ '[ , <posting> ] 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 [
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
- <feed-action> "feed.xml" add-responder
- <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
+ <planet-feed-action> "feed.xml" add-responder
+ <planet-factor-admin> <protected>
+ "administer Planet Factor" >>description
+ { can-administer-planet-factor? } >>capabilities
+ "admin" add-responder
<boilerplate>
{ planet-factor "planet-common" } >>template ;
<t:bind-each t:name="postings">
<h2 class="posting-title">
- <t:a t:value="link"><t:label t:name="title" /></t:a>
+ <t:a t:value="url"><t:label t:name="title" /></t:a>
</h2>
<p class="posting-body">
</p>
<p class="posting-date">
- <t:a t:value="link"><t:label t:name="pub-date" /></t:a>
+ <t:a t:value="url"><t:label t:name="pub-date" /></t:a>
</p>
</t:bind-each>
<delete-action> "delete" add-responder
<boilerplate>
{ todo-list "todo" } >>template
- f <protected> ;
+ <protected>
+ "view your todo list" >>description ;
| <t:a t:href="$todo-list/new">Add Item</t:a>
<t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
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 ;
-
: <user-list-action> ( -- action )
<page-action>
[ f <user> select-tuples "users" set-value ] >>init
[ 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
<delete-user-action> "delete" add-responder
<boilerplate>
{ user-admin "user-admin" } >>template
- { can-administer-users? } <protected> ;
+ <protected>
+ "administer users" >>description
+ { can-administer-users? } >>capabilities ;
: make-admin ( username -- )
<user>
| <t:a t:href="$user-admin/new">Add User</t:a>
<t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:form t:action="$wee-url">
+ <p>Shorten URL: <t:field t:name="url" t:size="40" /></p>
+ <input type="submit" value="Shorten" />
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <p>The URL:</p>
+ <blockquote><t:link t:name="url" /></blockquote>
+ <p>has been shortened to:</p>
+ <blockquote><t:link t:name="short" /></blockquote>
+ <p>enjoy!</p>
+
+</t:chloe>
--- /dev/null
+! 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>> ;
+
+: <shorten-action> ( -- action )
+ <page-action>
+ { wee-url "shorten" } >>template
+ [ { { "url" [ v-url ] } } validate-params ] >>validate
+ [
+ "$wee-url/show/" "url" value shorten append >url <redirect>
+ ] >>submit ;
+
+: <show-action> ( -- action )
+ <page-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 ;
+
+: <go-action> ( -- action )
+ <action>
+ "short" >>rest
+ [ { { "short" [ v-one-word ] } } validate-params ] >>init
+ [ "short" value expand-url <redirect> ] >>display ;
+
+: <wee-url> ( -- wee-url )
+ wee-url new-dispatcher
+ <shorten-action> "" add-responder
+ <show-action> "show" add-responder
+ <go-action> "go" add-responder
+ <boilerplate>
+ { wee-url "wee-url" } >>template ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>WeeURL!</t:title>
+
+ <div class="navbar"><t:a t:href="$wee-url">Shorten URL</t:a></div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
<ul>
<t:bind-each t:name="changes">
<li>
- <t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
+ <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
by
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/revisions.atom" t:query="title">
+ Revisions of <t:label t:name="title" />
+ </t:atom>
+
<t:call-next-template />
<div class="navbar">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/user-edits.atom" t:query="author">
+ Edits by <t:label t:name="author" />
+ </t:atom>
+
<t:title>Edits by <t:label t:name="author" /></t:title>
<ul>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/changes.atom">
+ Recent Changes
+ </t:atom>
+
<t:style t:include="resource:extra/webapps/wiki/wiki.css" />
<div class="navbar">
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
! 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
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 ;
{ "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 ;
+
: <revision> ( id -- revision )
revision new swap >>id ;
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
+: validate-author ( -- )
+ { { "author" [ v-username ] } } validate-params ;
+
: <main-article-action> ( -- action )
<action>
- [
- <url>
- "$wiki/view" >>path
- "Front Page" "title" set-query-param
- <redirect>
- ] >>display ;
+ [ "Front Page" view-url <redirect> ] >>display ;
: <view-article-action> ( -- action )
<action>
- "title" >>rest-param
+ "title" >>rest
[
validate-title
revision>> <revision> select-tuple from-object
{ wiki "view" } <chloe-content>
] [
- <url>
- "$wiki/edit" >>path
- swap "title" set-query-param
- <redirect>
+ edit-url <redirect>
] ?if
] >>display ;
: <view-revision-action> ( -- action )
<page-action>
[
- { { "id" [ v-integer ] } } validate-params
+ validate-integer-id
"id" value <revision>
select-tuple from-object
+ "view?title=" relative-link-prefix set
] >>init
{ wiki "view" } >>template ;
now >>date
logged-in-user get username>> >>author
"content" value >>content
- [ add-revision ]
- [
- <url>
- "$wiki/view" >>path
- swap title>> "title" set-query-param
- <redirect>
- ] bi
+ [ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit ;
+: list-revisions ( -- seq )
+ f <revision> "title" value >>title select-tuples
+ reverse-chronological-order ;
+
: <list-revisions-action> ( -- action )
<page-action>
[
validate-title
- f <revision> "title" value >>title select-tuples
- [ [ date>> ] compare invert-comparison ] sort
- "revisions" set-value
+ list-revisions "revisions" set-value
] >>init
-
{ wiki "revisions" } >>template ;
+: <list-revisions-feed-action> ( -- action )
+ <feed-action>
+ [ validate-title ] >>init
+ [ "Revisions of " "title" value append ] >>title
+ [ "title" value revisions-url ] >>url
+ [ list-revisions ] >>entries ;
+
: <rollback-action> ( -- action )
<action>
- [
- { { "id" [ v-integer ] } } validate-params
- ] >>validate
-
+ [ validate-integer-id ] >>validate
+
[
"id" value <revision> select-tuple clone f >>id
- [ add-revision ]
- [
- <url>
- "$wiki/view" >>path
- swap title>> "title" set-query-param
- <redirect>
- ] bi
+ [ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit ;
+: list-changes ( -- seq )
+ "id" value <revision> select-tuples
+ reverse-chronological-order ;
+
: <list-changes-action> ( -- action )
<page-action>
- [
- f <revision> select-tuples
- [ [ date>> ] compare invert-comparison ] sort
- "changes" set-value
- ] >>init
+ [ list-changes "changes" set-value ] >>init
{ wiki "changes" } >>template ;
+: <list-changes-feed-action> ( -- action )
+ <feed-action>
+ [ URL" $wiki/changes" ] >>url
+ [ "All changes" ] >>title
+ [ list-changes ] >>entries ;
+
: <delete-action> ( -- action )
<action>
[ validate-title ] >>validate
{ wiki "articles" } >>template ;
+: list-user-edits ( -- seq )
+ f <revision> "author" value >>author select-tuples
+ reverse-chronological-order ;
+
: <user-edits-action> ( -- action )
<page-action>
[
- { { "author" [ v-username ] } } validate-params
- f <revision> "author" value >>author
- select-tuples "user-edits" set-value
+ validate-author
+ list-user-edits "user-edits" set-value
] >>init
-
{ wiki "user-edits" } >>template ;
+: <user-edits-feed-action> ( -- action )
+ <feed-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
+
+: <article-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ { wiki "page-common" } >>template ;
+
: <wiki> ( -- dispatcher )
wiki new-dispatcher
- <dispatcher>
- <main-article-action> "" add-responder
- <view-article-action> "view" add-responder
- <view-revision-action> "revision" add-responder
- <list-revisions-action> "revisions" add-responder
- <diff-action> "diff" add-responder
- <edit-article-action> { } <protected> "edit" add-responder
- <boilerplate>
- { wiki "page-common" } >>template
- >>default
+ <main-article-action> <article-boilerplate> "" add-responder
+ <view-article-action> <article-boilerplate> "view" add-responder
+ <view-revision-action> <article-boilerplate> "revision" add-responder
+ <list-revisions-action> <article-boilerplate> "revisions" add-responder
+ <list-revisions-feed-action> "revisions.atom" add-responder
+ <diff-action> <article-boilerplate> "diff" add-responder
+ <edit-article-action> <article-boilerplate> <protected>
+ "edit wiki articles" >>description
+ "edit" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder
<list-changes-action> "changes" add-responder
- <delete-action> { } <protected> "delete" add-responder
+ <user-edits-feed-action> "user-edits.atom" add-responder
+ <list-changes-feed-action> "changes.atom" add-responder
+ <delete-action> <protected>
+ "delete wiki articles" >>description
+ { can-delete-wiki-articles? } >>capabilities
+ "delete" add-responder
<boilerplate>
{ wiki "wiki-common" } >>template ;
put-http-response ;
: test-rpc-arith
- "add" { 1 2 } <rpc-method> send-rpc xml>string
- "text/xml" swap "http://localhost:8080/responder/rpc/"
+ "add" { 1 2 } <rpc-method> send-rpc
+ "http://localhost:8080/responder/rpc/"
http-post ;
: 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 <rpc-method> r> post-rpc ;
"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)
(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))
projects / factor.git / commitdiff