Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: extra/pango/cairo/gadgets/gadgets.factordb4
Matthew Willis
commit
1f6530b16e
|
|
@ -139,7 +139,7 @@ HELP: new-assoc
|
|||
|
||||
HELP: assoc-find
|
||||
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
|
||||
{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." }
|
||||
{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." }
|
||||
{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ;
|
||||
|
||||
HELP: clear-assoc
|
||||
|
|
|
|||
|
|
@ -219,6 +219,16 @@ $nl
|
|||
{ $example "t \\ t eq? ." "t" }
|
||||
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
|
||||
|
||||
ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
|
||||
"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
|
||||
$nl
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "[ drop f ] unless" "swap and" }
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "[ ] [ ] ?if" "swap or" }
|
||||
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
|
||||
{ $code "[ L ] unless*" "L or" } ;
|
||||
|
||||
ARTICLE: "conditionals" "Conditionals and logic"
|
||||
"The basic conditionals:"
|
||||
{ $subsection if }
|
||||
|
|
@ -238,6 +248,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
|
|||
{ $subsection and }
|
||||
{ $subsection or }
|
||||
{ $subsection xor }
|
||||
{ $subsection "conditionals-boolean-equivalence" }
|
||||
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
|
||||
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
|
||||
|
||||
|
|
@ -720,9 +731,7 @@ HELP: unless*
|
|||
{ $description "Variant of " { $link if* } " with no true quotation." }
|
||||
{ $notes
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
|
||||
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
|
||||
{ $code "[ L ] unless*" "L or" } } ;
|
||||
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
|
||||
|
||||
HELP: ?if
|
||||
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }
|
||||
|
|
|
|||
|
|
@ -346,7 +346,7 @@ HELP: \
|
|||
{ $syntax "\\ word" }
|
||||
{ $values { "word" "a word" } }
|
||||
{ $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." }
|
||||
{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } } ;
|
||||
{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } "If " { $snippet "foo" } " is a symbol, the following two lines are equivalent:" { $code "foo" "\\ foo" } } ;
|
||||
|
||||
HELP: DEFER:
|
||||
{ $syntax "DEFER: word" }
|
||||
|
|
@ -526,6 +526,9 @@ HELP: PREDICATE:
|
|||
"it satisfies the predicate"
|
||||
}
|
||||
"Each predicate must be defined as a subclass of some other class. This ensures that predicates inheriting from disjoint classes do not need to be exhaustively tested during method dispatch."
|
||||
}
|
||||
{ $examples
|
||||
{ $code "USING: math ;" "PREDICATE: positive < integer 0 > ;" }
|
||||
} ;
|
||||
|
||||
HELP: TUPLE:
|
||||
|
|
|
|||
|
|
@ -21,3 +21,21 @@ blah
|
|||
init-request
|
||||
{ } "action-1" get call-responder
|
||||
] unit-test
|
||||
|
||||
<action>
|
||||
"a" >>rest
|
||||
[ "a" param string>number sq ] >>display
|
||||
"action-2" set
|
||||
|
||||
STRING: action-request-test-2
|
||||
GET http://foo/bar/123 HTTP/1.1
|
||||
|
||||
blah
|
||||
;
|
||||
|
||||
[ 25 ] [
|
||||
action-request-test-2 lf>crlf
|
||||
[ read-request ] with-string-reader
|
||||
init-request
|
||||
{ "5" } "action-2" get call-responder
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -2,20 +2,22 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences kernel assocs combinators
|
||||
validators http hashtables namespaces fry continuations locals
|
||||
io arrays math boxes
|
||||
io arrays math boxes splitting urls
|
||||
xml.entities
|
||||
http.server
|
||||
http.server.responses
|
||||
furnace
|
||||
furnace.flash
|
||||
html.elements
|
||||
html.components
|
||||
html.components
|
||||
html.templates.chloe
|
||||
html.templates.chloe.syntax ;
|
||||
IN: furnace.actions
|
||||
|
||||
SYMBOL: params
|
||||
|
||||
SYMBOL: rest-param
|
||||
SYMBOL: rest
|
||||
|
||||
: render-validation-messages ( -- )
|
||||
validation-messages get
|
||||
|
|
@ -27,7 +29,7 @@ SYMBOL: rest-param
|
|||
|
||||
CHLOE: validation-messages drop render-validation-messages ;
|
||||
|
||||
TUPLE: action rest-param init display validate submit ;
|
||||
TUPLE: action rest init display validate submit ;
|
||||
|
||||
: new-action ( class -- action )
|
||||
new
|
||||
|
|
@ -39,48 +41,68 @@ TUPLE: action rest-param init display validate submit ;
|
|||
: <action> ( -- action )
|
||||
action new-action ;
|
||||
|
||||
: flashed-variables ( -- seq )
|
||||
{ validation-messages named-validation-messages } ;
|
||||
|
||||
: handle-get ( action -- response )
|
||||
blank-values
|
||||
[ init>> call ]
|
||||
[ display>> call ]
|
||||
bi ;
|
||||
'[
|
||||
,
|
||||
[ init>> call ]
|
||||
[ drop flashed-variables restore-flash ]
|
||||
[ display>> call ]
|
||||
tri
|
||||
] with-exit-continuation ;
|
||||
|
||||
: validation-failed ( -- * )
|
||||
request get method>> "POST" =
|
||||
[ action get display>> call ] [ <400> ] if exit-with ;
|
||||
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
|
||||
|
||||
: handle-post ( action -- response )
|
||||
init-validation
|
||||
blank-values
|
||||
[ validate>> call ]
|
||||
[ submit>> call ] bi ;
|
||||
|
||||
: handle-rest-param ( arg -- )
|
||||
dup length 1 > action get rest-param>> not or
|
||||
[ <404> exit-with ] [
|
||||
action get rest-param>> associate rest-param set
|
||||
] if ;
|
||||
|
||||
M: action call-responder* ( path action -- response )
|
||||
dup action set
|
||||
'[
|
||||
, dup empty? [ drop ] [ handle-rest-param ] if
|
||||
|
||||
init-validation
|
||||
,
|
||||
request get
|
||||
[ request-params rest-param get assoc-union params set ]
|
||||
[ method>> ] bi
|
||||
{
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
] with-exit-continuation ;
|
||||
: (handle-post) ( action -- response )
|
||||
[ validate>> call ] [ submit>> call ] bi ;
|
||||
|
||||
: param ( name -- value )
|
||||
params get at ;
|
||||
|
||||
: revalidate-url-key "__u" ;
|
||||
|
||||
: check-url ( url -- ? )
|
||||
request get url>>
|
||||
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
|
||||
|
||||
: revalidate-url ( -- url/f )
|
||||
revalidate-url-key param dup [ >url dup check-url swap and ] when ;
|
||||
|
||||
: handle-post ( action -- response )
|
||||
'[
|
||||
form-nesting-key params get at " " split
|
||||
[ , (handle-post) ]
|
||||
[ swap '[ , , nest-values ] ] reduce
|
||||
call
|
||||
] with-exit-continuation
|
||||
[
|
||||
revalidate-url
|
||||
[ flashed-variables <flash-redirect> ] [ <403> ] if*
|
||||
] unless* ;
|
||||
|
||||
: handle-rest ( path action -- assoc )
|
||||
rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
|
||||
|
||||
: init-action ( path action -- )
|
||||
blank-values
|
||||
init-validation
|
||||
handle-rest
|
||||
request get request-params assoc-union params set ;
|
||||
|
||||
M: action call-responder* ( path action -- response )
|
||||
[ init-action ] keep
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case ;
|
||||
|
||||
M: action modify-form
|
||||
drop request get url>> revalidate-url-key hidden-form-field ;
|
||||
|
||||
: check-validation ( -- )
|
||||
validation-failed? [ validation-failed ] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,73 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces sequences arrays kernel
|
||||
assocs assocs.lib hashtables math.parser urls combinators
|
||||
furnace http http.server http.server.filters furnace.sessions
|
||||
html.elements html.templates.chloe.syntax ;
|
||||
IN: furnace.asides
|
||||
|
||||
TUPLE: asides < filter-responder ;
|
||||
|
||||
C: <asides> asides
|
||||
|
||||
: begin-aside* ( -- id )
|
||||
request get
|
||||
[ url>> ] [ post-data>> ] [ method>> ] tri 3array
|
||||
asides sget set-at-unique
|
||||
session-changed ;
|
||||
|
||||
: end-aside-post ( url post-data -- response )
|
||||
request [
|
||||
clone
|
||||
swap >>post-data
|
||||
swap >>url
|
||||
] change
|
||||
request get url>> path>> split-path
|
||||
asides get responder>> call-responder ;
|
||||
|
||||
ERROR: end-aside-in-get-error ;
|
||||
|
||||
: end-aside* ( url id -- response )
|
||||
request get method>> "POST" = [ end-aside-in-get-error ] unless
|
||||
asides sget at [
|
||||
first3 {
|
||||
{ "GET" [ drop <redirect> ] }
|
||||
{ "HEAD" [ drop <redirect> ] }
|
||||
{ "POST" [ end-aside-post ] }
|
||||
} case
|
||||
] [ <redirect> ] ?if ;
|
||||
|
||||
SYMBOL: aside-id
|
||||
|
||||
: aside-id-key "__a" ;
|
||||
|
||||
: begin-aside ( -- )
|
||||
begin-aside* aside-id set ;
|
||||
|
||||
: end-aside ( default -- response )
|
||||
aside-id [ f ] change end-aside* ;
|
||||
|
||||
M: asides call-responder*
|
||||
dup asides set
|
||||
aside-id-key request get request-params at aside-id set
|
||||
call-next-method ;
|
||||
|
||||
M: asides init-session*
|
||||
H{ } clone asides sset
|
||||
call-next-method ;
|
||||
|
||||
M: asides link-attr ( tag -- )
|
||||
drop
|
||||
"aside" optional-attr {
|
||||
{ "none" [ aside-id off ] }
|
||||
{ "begin" [ begin-aside ] }
|
||||
{ "current" [ ] }
|
||||
{ f [ ] }
|
||||
} case ;
|
||||
|
||||
M: asides modify-query ( query responder -- query' )
|
||||
drop
|
||||
aside-id get [ aside-id-key associate assoc-union ] when* ;
|
||||
|
||||
M: asides modify-form ( responder -- )
|
||||
drop aside-id get aside-id-key hidden-form-field ;
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors quotations assocs kernel splitting
|
||||
combinators sequences namespaces hashtables sets
|
||||
fry arrays threads qualified random validators
|
||||
fry arrays threads qualified random validators words
|
||||
io
|
||||
io.sockets
|
||||
io.encodings.utf8
|
||||
|
|
@ -26,14 +26,29 @@ furnace.auth
|
|||
furnace.auth.providers
|
||||
furnace.auth.providers.db
|
||||
furnace.actions
|
||||
furnace.flows
|
||||
furnace.asides
|
||||
furnace.flash
|
||||
furnace.sessions
|
||||
furnace.boilerplate ;
|
||||
QUALIFIED: smtp
|
||||
IN: furnace.auth.login
|
||||
|
||||
: word>string ( word -- string )
|
||||
[ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
|
||||
|
||||
: words>strings ( seq -- seq' )
|
||||
[ word>string ] map ;
|
||||
|
||||
: string>word ( string -- word )
|
||||
":" split1 swap lookup ;
|
||||
|
||||
: strings>words ( seq -- seq' )
|
||||
[ string>word ] map ;
|
||||
|
||||
TUPLE: login < dispatcher users checksum ;
|
||||
|
||||
TUPLE: protected < filter-responder description capabilities ;
|
||||
|
||||
: users ( -- provider )
|
||||
login get users>> ;
|
||||
|
||||
|
|
@ -64,7 +79,7 @@ M: user-saver dispose
|
|||
|
||||
! ! ! Login
|
||||
: successful-login ( user -- response )
|
||||
username>> set-uid URL" $login" end-flow ;
|
||||
username>> set-uid URL" $login" end-aside ;
|
||||
|
||||
: login-failed ( -- * )
|
||||
"invalid username or password" validation-error
|
||||
|
|
@ -72,6 +87,13 @@ M: user-saver dispose
|
|||
|
||||
: <login-action> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
protected fget [
|
||||
[ description>> "description" set-value ]
|
||||
[ capabilities>> words>strings "capabilities" set-value ] bi
|
||||
] when*
|
||||
] >>init
|
||||
|
||||
{ login "login" } >>template
|
||||
|
||||
[
|
||||
|
|
@ -177,7 +199,7 @@ M: user-saver dispose
|
|||
|
||||
drop
|
||||
|
||||
URL" $login" end-flow
|
||||
URL" $login" end-aside
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Password recovery
|
||||
|
|
@ -290,23 +312,23 @@ SYMBOL: lost-password-from
|
|||
<action>
|
||||
[
|
||||
f set-uid
|
||||
URL" $login" end-flow
|
||||
URL" $login" end-aside
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Authentication logic
|
||||
|
||||
TUPLE: protected < filter-responder capabilities ;
|
||||
|
||||
C: <protected> protected
|
||||
: <protected> ( responder -- protected )
|
||||
protected new
|
||||
swap >>responder ;
|
||||
|
||||
: show-login-page ( -- response )
|
||||
begin-flow
|
||||
URL" $login/login" <redirect> ;
|
||||
begin-aside
|
||||
URL" $login/login" { protected } <flash-redirect> ;
|
||||
|
||||
: check-capabilities ( responder user -- ? )
|
||||
[ capabilities>> ] bi@ subset? ;
|
||||
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
dup protected set
|
||||
uid dup [
|
||||
users get-user 2dup check-capabilities [
|
||||
[ logged-in-user set ] [ save-user-after ] bi
|
||||
|
|
@ -337,7 +359,9 @@ M: login call-responder* ( path responder -- response )
|
|||
! ! ! Configuration
|
||||
|
||||
: allow-edit-profile ( login -- login )
|
||||
<edit-profile-action> f <protected> <login-boilerplate>
|
||||
<edit-profile-action> <protected>
|
||||
"edit your profile" >>description
|
||||
<login-boilerplate>
|
||||
"edit-profile" add-responder ;
|
||||
|
||||
: allow-registration ( login -- login )
|
||||
|
|
|
|||
|
|
@ -4,6 +4,19 @@
|
|||
|
||||
<t:title>Login</t:title>
|
||||
|
||||
<t:if t:value="description">
|
||||
<p>You must log in to <t:label t:name="description" />.</p>
|
||||
</t:if>
|
||||
|
||||
<t:if t:value="capabilities">
|
||||
<p>Your user must have the following capabilities:</p>
|
||||
<ul>
|
||||
<t:each t:name="capabilities">
|
||||
<li><t:label t:name="value" /></li>
|
||||
</t:each>
|
||||
</ul>
|
||||
</t:if>
|
||||
|
||||
<t:form t:action="login">
|
||||
|
||||
<table>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs assocs.lib kernel sequences urls
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace furnace.sessions ;
|
||||
IN: furnace.flash
|
||||
|
||||
: flash-id-key "__f" ;
|
||||
|
||||
TUPLE: flash-scopes < filter-responder ;
|
||||
|
||||
C: <flash-scopes> flash-scopes
|
||||
|
||||
SYMBOL: flash-scope
|
||||
|
||||
: fget ( key -- value ) flash-scope get at ;
|
||||
|
||||
M: flash-scopes call-responder*
|
||||
flash-id-key
|
||||
request get request-params at
|
||||
flash-scopes sget at flash-scope set
|
||||
call-next-method ;
|
||||
|
||||
M: flash-scopes init-session*
|
||||
H{ } clone flash-scopes sset
|
||||
call-next-method ;
|
||||
|
||||
: make-flash-scope ( seq -- id )
|
||||
[ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
|
||||
session-changed ;
|
||||
|
||||
: <flash-redirect> ( url seq -- response )
|
||||
make-flash-scope
|
||||
[ clone ] dip flash-id-key set-query-param
|
||||
<redirect> ;
|
||||
|
||||
: restore-flash ( seq -- )
|
||||
[ flash-scope get key? ] filter [ [ fget ] keep set ] each ;
|
||||
|
|
@ -1,78 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces sequences arrays kernel
|
||||
assocs assocs.lib hashtables math.parser urls combinators
|
||||
furnace http http.server http.server.filters furnace.sessions
|
||||
html.elements html.templates.chloe.syntax ;
|
||||
IN: furnace.flows
|
||||
|
||||
TUPLE: flows < filter-responder ;
|
||||
|
||||
C: <flows> flows
|
||||
|
||||
: begin-flow* ( -- id )
|
||||
request get
|
||||
[ url>> ] [ post-data>> ] [ method>> ] tri 3array
|
||||
flows sget set-at-unique
|
||||
session-changed ;
|
||||
|
||||
: end-flow-post ( url post-data -- response )
|
||||
request [
|
||||
clone
|
||||
"POST" >>method
|
||||
swap >>post-data
|
||||
swap >>url
|
||||
] change
|
||||
request get url>> path>> split-path
|
||||
flows get responder>> call-responder ;
|
||||
|
||||
: end-flow* ( url id -- response )
|
||||
flows sget at [
|
||||
first3 {
|
||||
{ "GET" [ drop <redirect> ] }
|
||||
{ "HEAD" [ drop <redirect> ] }
|
||||
{ "POST" [ end-flow-post ] }
|
||||
} case
|
||||
] [ <redirect> ] ?if ;
|
||||
|
||||
SYMBOL: flow-id
|
||||
|
||||
: flow-id-key "factorflowid" ;
|
||||
|
||||
: begin-flow ( -- )
|
||||
begin-flow* flow-id set ;
|
||||
|
||||
: end-flow ( default -- response )
|
||||
flow-id get end-flow* ;
|
||||
|
||||
M: flows call-responder*
|
||||
dup flows set
|
||||
flow-id-key request get request-params at flow-id set
|
||||
call-next-method ;
|
||||
|
||||
M: flows init-session*
|
||||
H{ } clone flows sset
|
||||
call-next-method ;
|
||||
|
||||
M: flows link-attr ( tag -- )
|
||||
drop
|
||||
"flow" optional-attr {
|
||||
{ "none" [ flow-id off ] }
|
||||
{ "begin" [ begin-flow ] }
|
||||
{ "current" [ ] }
|
||||
{ f [ ] }
|
||||
} case ;
|
||||
|
||||
M: flows modify-query ( query responder -- query' )
|
||||
drop
|
||||
flow-id get [ flow-id-key associate assoc-union ] when* ;
|
||||
|
||||
M: flows hidden-form-field ( responder -- )
|
||||
drop
|
||||
flow-id get [
|
||||
<input
|
||||
"hidden" =type
|
||||
flow-id-key =name
|
||||
=value
|
||||
input/>
|
||||
] when* ;
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
IN: furnace.tests
|
||||
USING: http.server.dispatchers http.server.responses
|
||||
http.server furnace tools.test kernel namespaces accessors ;
|
||||
http.server furnace tools.test kernel namespaces accessors
|
||||
io.streams.string ;
|
||||
TUPLE: funny-dispatcher < dispatcher ;
|
||||
|
||||
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
|
||||
|
|
@ -28,3 +29,7 @@ M: base-path-check-responder call-responder*
|
|||
V{ } responder-nesting set
|
||||
"a/b/c" split-path main-responder get call-responder body>>
|
||||
] unit-test
|
||||
|
||||
[ "<input type='hidden' name='foo' value='&&&'/>" ]
|
||||
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
|
||||
unit-test
|
||||
|
|
|
|||
|
|
@ -2,12 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel combinators assocs
|
||||
continuations namespaces sequences splitting words
|
||||
vocabs.loader classes
|
||||
fry urls multiline
|
||||
vocabs.loader classes strings
|
||||
fry urls multiline present
|
||||
xml
|
||||
xml.data
|
||||
xml.entities
|
||||
xml.writer
|
||||
xml.utilities
|
||||
html.components
|
||||
html.elements
|
||||
html.templates
|
||||
|
|
@ -19,6 +19,7 @@ http.server.redirection
|
|||
http.server.responses
|
||||
qualified ;
|
||||
QUALIFIED-WITH: assocs a
|
||||
EXCLUDE: xml.utilities => children>string ;
|
||||
IN: furnace
|
||||
|
||||
: nested-responders ( -- seq )
|
||||
|
|
@ -51,12 +52,16 @@ GENERIC: modify-query ( query responder -- query' )
|
|||
|
||||
M: object modify-query drop ;
|
||||
|
||||
: adjust-url ( url -- url' )
|
||||
GENERIC: adjust-url ( url -- url' )
|
||||
|
||||
M: url adjust-url
|
||||
clone
|
||||
[ [ modify-query ] each-responder ] change-query
|
||||
[ resolve-base-path ] change-path
|
||||
relative-to-request ;
|
||||
|
||||
M: string adjust-url ;
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
adjust-url request get method>> {
|
||||
{ "GET" [ <temporary-redirect> ] }
|
||||
|
|
@ -64,15 +69,19 @@ M: object modify-query drop ;
|
|||
{ "POST" [ <permanent-redirect> ] }
|
||||
} case ;
|
||||
|
||||
GENERIC: hidden-form-field ( responder -- )
|
||||
GENERIC: modify-form ( responder -- )
|
||||
|
||||
M: object hidden-form-field drop ;
|
||||
M: object modify-form drop ;
|
||||
|
||||
: request-params ( request -- assoc )
|
||||
dup method>> {
|
||||
{ "GET" [ url>> query>> ] }
|
||||
{ "HEAD" [ url>> query>> ] }
|
||||
{ "POST" [ post-data>> ] }
|
||||
{ "POST" [
|
||||
post-data>>
|
||||
dup content-type>> "application/x-www-form-urlencoded" =
|
||||
[ content>> ] [ drop f ] if
|
||||
] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: exit-continuation
|
||||
|
|
@ -88,7 +97,7 @@ SYMBOL: exit-continuation
|
|||
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
||||
|
||||
CHLOE: atom
|
||||
[ "title" required-attr ]
|
||||
[ children>string ]
|
||||
[ "href" required-attr ]
|
||||
[ "query" optional-attr parse-query-attr ] tri
|
||||
<url>
|
||||
|
|
@ -128,20 +137,34 @@ CHLOE: a
|
|||
[ drop </a> ]
|
||||
tri ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
over [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: form-nesting-key "__n" ;
|
||||
|
||||
: form-magic ( tag -- )
|
||||
[ modify-form ] each-responder
|
||||
nested-values get " " join f like form-nesting-key hidden-form-field
|
||||
"for" optional-attr [ hidden render ] when* ;
|
||||
|
||||
: form-start-tag ( tag -- )
|
||||
[
|
||||
[
|
||||
<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
|
||||
|
|
@ -167,17 +190,3 @@ CHLOE: button
|
|||
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
|
||||
[ nip ]
|
||||
} 2cleave process-chloe-tag ;
|
||||
|
||||
: attr>word ( value -- word/f )
|
||||
dup ":" split1 swap lookup
|
||||
[ ] [ "No such word: " swap append throw ] ?if ;
|
||||
|
||||
: attr>var ( value -- word/f )
|
||||
attr>word dup symbol? [
|
||||
"Must be a symbol: " swap append throw
|
||||
] unless ;
|
||||
|
||||
: if-satisfied? ( tag -- ? )
|
||||
"code" required-attr attr>word execute ;
|
||||
|
||||
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -1,14 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel fry
|
||||
rss http.server.responses furnace.actions ;
|
||||
IN: furnace.rss
|
||||
|
||||
: <feed-content> ( body -- response )
|
||||
feed>xml "application/atom+xml" <content> ;
|
||||
|
||||
TUPLE: feed-action < action feed ;
|
||||
|
||||
: <feed-action> ( -- feed )
|
||||
feed-action new-action
|
||||
dup '[ , feed>> call <feed-content> ] >>display ;
|
||||
|
|
@ -109,14 +109,14 @@ M: session-saver dispose
|
|||
[ session set ] [ save-session-after ] bi
|
||||
sessions get responder>> call-responder ;
|
||||
|
||||
: session-id-key "factorsessid" ;
|
||||
: session-id-key "__s" ;
|
||||
|
||||
: cookie-session-id ( request -- id/f )
|
||||
session-id-key get-cookie
|
||||
dup [ value>> string>number ] when ;
|
||||
|
||||
: post-session-id ( request -- id/f )
|
||||
session-id-key swap post-data>> at string>number ;
|
||||
session-id-key swap request-params at string>number ;
|
||||
|
||||
: request-session-id ( -- id/f )
|
||||
request get dup method>> {
|
||||
|
|
@ -137,13 +137,8 @@ M: session-saver dispose
|
|||
: put-session-cookie ( response -- response' )
|
||||
session get id>> number>string <session-cookie> put-cookie ;
|
||||
|
||||
M: sessions hidden-form-field ( responder -- )
|
||||
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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,53 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences fry sequences.lib
|
||||
combinators syndication
|
||||
http.server.responses http.server.redirection
|
||||
furnace furnace.actions ;
|
||||
IN: furnace.syndication
|
||||
|
||||
GENERIC: feed-entry-title ( object -- string )
|
||||
|
||||
GENERIC: feed-entry-date ( object -- timestamp )
|
||||
|
||||
GENERIC: feed-entry-url ( object -- url )
|
||||
|
||||
GENERIC: feed-entry-description ( object -- description )
|
||||
|
||||
M: object feed-entry-description drop f ;
|
||||
|
||||
GENERIC: >entry ( object -- entry )
|
||||
|
||||
M: entry >entry ;
|
||||
|
||||
M: object >entry
|
||||
<entry>
|
||||
swap {
|
||||
[ feed-entry-title >>title ]
|
||||
[ feed-entry-date >>date ]
|
||||
[ feed-entry-url >>url ]
|
||||
[ feed-entry-description >>description ]
|
||||
} cleave ;
|
||||
|
||||
: process-entries ( seq -- seq' )
|
||||
20 short head-slice [
|
||||
>entry clone
|
||||
[ adjust-url relative-to-request ] change-url
|
||||
] map ;
|
||||
|
||||
: <feed-content> ( body -- response )
|
||||
feed>xml "application/atom+xml" <content> ;
|
||||
|
||||
TUPLE: feed-action < action title url entries ;
|
||||
|
||||
: <feed-action> ( -- action )
|
||||
feed-action new-action
|
||||
dup '[
|
||||
feed new
|
||||
,
|
||||
[ title>> call >>title ]
|
||||
[ url>> call adjust-url relative-to-request >>url ]
|
||||
[ entries>> call process-entries >>entries ]
|
||||
tri
|
||||
<feed-content>
|
||||
] >>display ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser-combinators regexp lazy-lists sequences kernel
|
||||
USING: parser-combinators regexp lists sequences kernel
|
||||
promises strings unicode.case ;
|
||||
IN: globs
|
||||
|
||||
|
|
|
|||
|
|
@ -17,8 +17,6 @@ TUPLE: color red green blue ;
|
|||
|
||||
[ ] [ "jimmy" "red" set-value ] unit-test
|
||||
|
||||
[ "123.5" ] [ 123.5 object>string ] unit-test
|
||||
|
||||
[ "jimmy" ] [
|
||||
[
|
||||
"red" label render
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting
|
|||
mirrors hashtables combinators continuations math strings
|
||||
fry locals calendar calendar.format xml.entities validators
|
||||
html.elements html.streams xmode.code2html farkup inspector
|
||||
lcs.diff2html urls ;
|
||||
lcs.diff2html urls present ;
|
||||
IN: html.components
|
||||
|
||||
SYMBOL: values
|
||||
|
|
@ -29,22 +29,36 @@ SYMBOL: values
|
|||
: deposit-slots ( destination names -- )
|
||||
[ <mirror> ] dip deposit-values ;
|
||||
|
||||
: with-each-index ( seq quot -- )
|
||||
'[
|
||||
: with-each-value ( name quot -- )
|
||||
[ value ] dip '[
|
||||
[
|
||||
values [ clone ] change
|
||||
1+ "index" set-value @
|
||||
1+ "index" set-value
|
||||
"value" set-value
|
||||
@
|
||||
] with-scope
|
||||
] each-index ; inline
|
||||
|
||||
: with-each-value ( seq quot -- )
|
||||
'[ "value" set-value @ ] with-each-index ; inline
|
||||
: with-each-object ( name quot -- )
|
||||
[ value ] dip '[
|
||||
[
|
||||
blank-values
|
||||
1+ "index" set-value
|
||||
from-object
|
||||
@
|
||||
] with-scope
|
||||
] each-index ; inline
|
||||
|
||||
: with-each-object ( seq quot -- )
|
||||
'[ from-object @ ] with-each-index ; inline
|
||||
SYMBOL: nested-values
|
||||
|
||||
: with-values ( object quot -- )
|
||||
'[ blank-values , from-object @ ] with-scope ; inline
|
||||
: with-values ( name quot -- )
|
||||
'[
|
||||
,
|
||||
[ nested-values [ swap prefix ] change ]
|
||||
[ value blank-values from-object ]
|
||||
bi
|
||||
@
|
||||
] with-scope ; inline
|
||||
|
||||
: nest-values ( name quot -- )
|
||||
swap [
|
||||
|
|
@ -67,13 +81,13 @@ GENERIC: render* ( value name render -- )
|
|||
<PRIVATE
|
||||
|
||||
: render-input ( value name type -- )
|
||||
<input =type =name object>string =value input/> ;
|
||||
<input =type =name present =value input/> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: label
|
||||
|
||||
M: label render* 2drop object>string escape-string write ;
|
||||
M: label render* 2drop present escape-string write ;
|
||||
|
||||
SINGLETON: hidden
|
||||
|
||||
|
|
@ -82,9 +96,9 @@ M: hidden render* drop "hidden" render-input ;
|
|||
: render-field ( value name size type -- )
|
||||
<input
|
||||
=type
|
||||
[ object>string =size ] when*
|
||||
[ present =size ] when*
|
||||
=name
|
||||
object>string =value
|
||||
present =value
|
||||
input/> ;
|
||||
|
||||
TUPLE: field size ;
|
||||
|
|
@ -111,11 +125,11 @@ TUPLE: textarea rows cols ;
|
|||
|
||||
M: textarea render*
|
||||
<textarea
|
||||
[ rows>> [ object>string =rows ] when* ]
|
||||
[ 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
|
||||
|
|
@ -126,7 +140,7 @@ TUPLE: choice size multiple choices ;
|
|||
|
||||
: render-option ( text selected? -- )
|
||||
<option [ "true" =selected ] when option>
|
||||
object>string escape-string write
|
||||
present escape-string write
|
||||
</option> ;
|
||||
|
||||
: render-options ( options selected -- )
|
||||
|
|
@ -135,7 +149,7 @@ TUPLE: choice size multiple choices ;
|
|||
M: choice render*
|
||||
<select
|
||||
swap =name
|
||||
dup size>> [ object>string =size ] when*
|
||||
dup size>> [ present =size ] when*
|
||||
dup multiple>> [ "true" =multiple ] when
|
||||
select>
|
||||
[ choices>> value ] [ multiple>> ] bi
|
||||
|
|
@ -162,12 +176,18 @@ M: checkbox render*
|
|||
GENERIC: link-title ( obj -- string )
|
||||
GENERIC: link-href ( obj -- url )
|
||||
|
||||
M: string link-title ;
|
||||
M: string link-href ;
|
||||
|
||||
M: url link-title ;
|
||||
M: url link-href ;
|
||||
|
||||
SINGLETON: link
|
||||
|
||||
M: link render*
|
||||
2drop
|
||||
<a dup link-href =href a>
|
||||
link-title object>string escape-string write
|
||||
link-title present escape-string write
|
||||
</a> ;
|
||||
|
||||
! XMode code component
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
USING: io kernel namespaces prettyprint quotations
|
||||
sequences strings words xml.entities compiler.units effects
|
||||
urls math math.parser combinators calendar calendar.format ;
|
||||
urls math math.parser combinators present ;
|
||||
|
||||
IN: html.elements
|
||||
|
||||
|
|
@ -127,22 +127,11 @@ SYMBOL: html
|
|||
dup def-for-html-word-<foo
|
||||
def-for-html-word-foo/> ;
|
||||
|
||||
: object>string ( object -- string )
|
||||
#! Should this be generic and in the core?
|
||||
{
|
||||
{ [ dup real? ] [ number>string ] }
|
||||
{ [ dup timestamp? ] [ timestamp>string ] }
|
||||
{ [ dup url? ] [ url>string ] }
|
||||
{ [ dup string? ] [ ] }
|
||||
{ [ dup word? ] [ word-name ] }
|
||||
{ [ dup not ] [ drop "" ] }
|
||||
} cond ;
|
||||
|
||||
: write-attr ( value name -- )
|
||||
" " write-html
|
||||
write-html
|
||||
"='" write-html
|
||||
object>string escape-quoted-string write-html
|
||||
present escape-quoted-string write-html
|
||||
"'" write-html ;
|
||||
|
||||
: attribute-effect T{ effect f { "string" } 0 } ;
|
||||
|
|
|
|||
|
|
@ -148,3 +148,35 @@ TUPLE: person first-name last-name ;
|
|||
"test9" test-template call-template
|
||||
] run-template
|
||||
] unit-test
|
||||
|
||||
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
|
||||
|
||||
[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
|
||||
[
|
||||
"test10" test-template call-template
|
||||
] run-template
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
|
||||
[ ] [
|
||||
H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
|
||||
] unit-test
|
||||
|
||||
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
|
||||
[
|
||||
"test11" test-template call-template
|
||||
] run-template [ blank? not ] filter
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
blank-values
|
||||
{ "a" "b" } "choices" set-value
|
||||
"true" "b" set-value
|
||||
] unit-test
|
||||
|
||||
[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
|
||||
[
|
||||
"test12" test-template call-template
|
||||
] run-template
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors kernel sequences combinators kernel namespaces
|
||||
classes.tuple assocs splitting words arrays memoize
|
||||
io io.files io.encodings.utf8 io.streams.string
|
||||
unicode.case tuple-syntax mirrors fry math urls
|
||||
unicode.case tuple-syntax mirrors fry math urls present
|
||||
multiline xml xml.data xml.writer xml.utilities
|
||||
html.elements
|
||||
html.components
|
||||
|
|
@ -68,7 +68,7 @@ CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
|
|||
|
||||
: (bind-tag) ( tag quot -- )
|
||||
[
|
||||
[ "name" required-attr value ] keep
|
||||
[ "name" required-attr ] keep
|
||||
'[ , process-tag-children ]
|
||||
] dip call ; inline
|
||||
|
||||
|
|
@ -85,6 +85,17 @@ CHLOE: comment drop ;
|
|||
|
||||
CHLOE: call-next-template drop call-next-template ;
|
||||
|
||||
: attr>word ( value -- word/f )
|
||||
dup ":" split1 swap lookup
|
||||
[ ] [ "No such word: " swap append throw ] ?if ;
|
||||
|
||||
: if-satisfied? ( tag -- ? )
|
||||
[ "code" optional-attr [ attr>word execute ] [ t ] if* ]
|
||||
[ "value" optional-attr [ value ] [ t ] if* ]
|
||||
bi and ;
|
||||
|
||||
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
|
||||
|
||||
CHLOE-SINGLETON: label
|
||||
CHLOE-SINGLETON: link
|
||||
CHLOE-SINGLETON: farkup
|
||||
|
|
@ -116,7 +127,7 @@ CHLOE-TUPLE: code
|
|||
: expand-attrs ( tag -- tag )
|
||||
dup [ tag? ] is? [
|
||||
clone [
|
||||
[ "@" ?head [ value object>string ] when ] assoc-map
|
||||
[ "@" ?head [ value present ] when ] assoc-map
|
||||
] change-attrs
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:bind t:name="a"><t:form t:action="foo"/></t:bind></t:chloe>
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<table>
|
||||
<t:bind t:name="person">
|
||||
<tr>
|
||||
<td><t:label t:name="first-name"/></td>
|
||||
<td><t:label t:name="last-name"/></td>
|
||||
</tr>
|
||||
</t:bind>
|
||||
</table>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:each t:name="choices"><t:checkbox t:name="@value" t:label="@value" /></t:each></t:chloe>
|
||||
|
|
@ -22,7 +22,7 @@ DEFER: http-request
|
|||
SYMBOL: redirects
|
||||
|
||||
: redirect-url ( request url -- request )
|
||||
'[ , >url derive-url ensure-port ] change-url ;
|
||||
'[ , >url ensure-port derive-url ensure-port ] change-url ;
|
||||
|
||||
: do-redirect ( response data -- response data )
|
||||
over code>> 300 399 between? [
|
||||
|
|
@ -100,12 +100,11 @@ M: download-failed error.
|
|||
: download ( url -- )
|
||||
dup download-name download-to ;
|
||||
|
||||
: <post-request> ( content-type content url -- request )
|
||||
: <post-request> ( post-data url -- request )
|
||||
<request>
|
||||
"POST" >>method
|
||||
swap >url ensure-port >>url
|
||||
swap >>post-data
|
||||
swap >>post-data-type ;
|
||||
swap >>post-data ;
|
||||
|
||||
: http-post ( content-type content url -- response data )
|
||||
: http-post ( post-data url -- response data )
|
||||
<post-request> http-request ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
USING: http tools.test multiline tuple-syntax
|
||||
io.streams.string kernel arrays splitting sequences
|
||||
assocs io.sockets db db.sqlite continuations urls ;
|
||||
assocs io.sockets db db.sqlite continuations urls hashtables ;
|
||||
IN: http.tests
|
||||
|
||||
: lf>crlf "\n" split "\r\n" join ;
|
||||
|
||||
STRING: read-request-test-1
|
||||
GET http://foo/bar HTTP/1.1
|
||||
POST http://foo/bar HTTP/1.1
|
||||
Some-Header: 1
|
||||
Some-Header: 2
|
||||
Content-Length: 4
|
||||
Content-type: application/octet-stream
|
||||
|
||||
blah
|
||||
;
|
||||
|
|
@ -17,10 +18,10 @@ blah
|
|||
[
|
||||
TUPLE{ request
|
||||
url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
|
||||
method: "GET"
|
||||
method: "POST"
|
||||
version: "1.1"
|
||||
header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
|
||||
post-data: "blah"
|
||||
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
|
||||
post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
|
||||
cookies: V{ }
|
||||
}
|
||||
] [
|
||||
|
|
@ -30,8 +31,9 @@ blah
|
|||
] unit-test
|
||||
|
||||
STRING: read-request-test-1'
|
||||
GET /bar HTTP/1.1
|
||||
POST /bar HTTP/1.1
|
||||
content-length: 4
|
||||
content-type: application/octet-stream
|
||||
some-header: 1; 2
|
||||
|
||||
blah
|
||||
|
|
@ -87,7 +89,7 @@ blah
|
|||
code: 404
|
||||
message: "not found"
|
||||
header: H{ { "content-type" "text/html; charset=UTF8" } }
|
||||
cookies: V{ }
|
||||
cookies: { }
|
||||
content-type: "text/html"
|
||||
content-charset: "UTF8"
|
||||
}
|
||||
|
|
@ -172,7 +174,7 @@ test-db [
|
|||
[ ] [
|
||||
[
|
||||
<dispatcher>
|
||||
<action> f <protected>
|
||||
<action> <protected>
|
||||
<login>
|
||||
<sessions>
|
||||
"" add-responder
|
||||
|
|
@ -219,3 +221,56 @@ test-db [
|
|||
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
|
||||
|
||||
USING: html.components html.elements xml xml.utilities validators
|
||||
furnace furnace.flash ;
|
||||
|
||||
SYMBOL: a
|
||||
|
||||
[ ] [
|
||||
[
|
||||
<dispatcher>
|
||||
<action>
|
||||
[ a get-global "a" set-value ] >>init
|
||||
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
|
||||
[ { { "a" [ v-integer ] } } validate-params ] >>validate
|
||||
[ "a" value a set-global URL" " <redirect> ] >>submit
|
||||
<flash-scopes>
|
||||
<sessions>
|
||||
>>default
|
||||
add-quit-action
|
||||
test-db <db-persistence>
|
||||
main-responder set
|
||||
|
||||
[ 1237 httpd ] "HTTPD test" spawn drop
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ ] [ 100 sleep ] unit-test
|
||||
|
||||
3 a set-global
|
||||
|
||||
: test-a string>xml "input" tag-named "value" swap at ;
|
||||
|
||||
[ "3" ] [
|
||||
"http://localhost:1237/" http-get*
|
||||
swap dup cookies>> "cookies" set session-id-key get-cookie
|
||||
value>> "session-id" set test-a
|
||||
] unit-test
|
||||
|
||||
[ "4" ] [
|
||||
H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
|
||||
"http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
|
||||
] unit-test
|
||||
|
||||
[ 4 ] [ a get-global ] unit-test
|
||||
|
||||
! Test flash scope
|
||||
[ "xyz" ] [
|
||||
H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
|
||||
"http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
|
||||
] unit-test
|
||||
|
||||
[ 4 ] [ a get-global ] unit-test
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@ USING: accessors kernel combinators math namespaces
|
|||
|
||||
assocs sequences splitting sorting sets debugger
|
||||
strings vectors hashtables quotations arrays byte-arrays
|
||||
math.parser calendar calendar.format
|
||||
math.parser calendar calendar.format present
|
||||
|
||||
io io.server io.sockets.secure
|
||||
|
||||
unicode.case unicode.categories qualified
|
||||
|
||||
urls html.templates ;
|
||||
urls html.templates xml xml.data xml.writer ;
|
||||
|
||||
EXCLUDE: fry => , ;
|
||||
|
||||
|
|
@ -54,11 +54,9 @@ IN: http
|
|||
|
||||
: header-value>string ( value -- string )
|
||||
{
|
||||
{ [ dup number? ] [ number>string ] }
|
||||
{ [ dup timestamp? ] [ timestamp>http-string ] }
|
||||
{ [ dup url? ] [ url>string ] }
|
||||
{ [ dup string? ] [ ] }
|
||||
{ [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
|
||||
{ [ dup array? ] [ [ header-value>string ] map "; " join ] }
|
||||
[ present ]
|
||||
} cond ;
|
||||
|
||||
: check-header-string ( str -- str )
|
||||
|
|
@ -132,7 +130,6 @@ url
|
|||
version
|
||||
header
|
||||
post-data
|
||||
post-data-type
|
||||
cookies ;
|
||||
|
||||
: set-header ( request/response value key -- request/response )
|
||||
|
|
@ -177,19 +174,27 @@ cookies ;
|
|||
: header ( request/response key -- value )
|
||||
swap header>> at ;
|
||||
|
||||
SYMBOL: max-post-request
|
||||
TUPLE: post-data raw content content-type ;
|
||||
|
||||
1024 256 * max-post-request set-global
|
||||
: <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
|
||||
|
|
@ -197,13 +202,6 @@ SYMBOL: max-post-request
|
|||
ensure-port
|
||||
drop ;
|
||||
|
||||
: extract-post-data-type ( request -- request )
|
||||
dup "content-type" header >>post-data-type ;
|
||||
|
||||
: parse-post-data ( request -- request )
|
||||
dup post-data-type>> "application/x-www-form-urlencoded" =
|
||||
[ dup post-data>> query>assoc >>post-data ] when ;
|
||||
|
||||
: extract-cookies ( request -- request )
|
||||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||
|
||||
|
|
@ -225,25 +223,17 @@ SYMBOL: max-post-request
|
|||
read-post-data
|
||||
detect-protocol
|
||||
extract-host
|
||||
extract-post-data-type
|
||||
parse-post-data
|
||||
extract-cookies ;
|
||||
|
||||
: write-method ( request -- request )
|
||||
dup method>> write bl ;
|
||||
|
||||
: write-request-url ( request -- request )
|
||||
dup url>> relative-url url>string write bl ;
|
||||
dup url>> relative-url present write bl ;
|
||||
|
||||
: write-version ( request -- request )
|
||||
"HTTP/" write dup request-version write crlf ;
|
||||
|
||||
: unparse-post-data ( request -- request )
|
||||
dup post-data>> dup sequence? [ drop ] [
|
||||
assoc>query >>post-data
|
||||
"application/x-www-form-urlencoded" >>post-data-type
|
||||
] if ;
|
||||
|
||||
: url-host ( url -- string )
|
||||
[ host>> ] [ port>> ] bi dup "http" protocol-port =
|
||||
[ drop ] [ ":" swap number>string 3append ] if ;
|
||||
|
|
@ -251,13 +241,33 @@ SYMBOL: max-post-request
|
|||
: write-request-header ( request -- request )
|
||||
dup header>> >hashtable
|
||||
over url>> host>> [ over url>> url-host "host" pick set-at ] when
|
||||
over post-data>> [ length "content-length" pick set-at ] when*
|
||||
over post-data-type>> [ "content-type" pick set-at ] when*
|
||||
over post-data>> [
|
||||
[ raw>> length "content-length" pick set-at ]
|
||||
[ content-type>> "content-type" pick set-at ]
|
||||
bi
|
||||
] when*
|
||||
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
|
||||
write-header ;
|
||||
|
||||
GENERIC: >post-data ( object -- post-data )
|
||||
|
||||
M: post-data >post-data ;
|
||||
|
||||
M: string >post-data "application/octet-stream" <post-data> ;
|
||||
|
||||
M: byte-array >post-data "application/octet-stream" <post-data> ;
|
||||
|
||||
M: xml >post-data xml>string "text/xml" <post-data> ;
|
||||
|
||||
M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
|
||||
|
||||
M: f >post-data ;
|
||||
|
||||
: unparse-post-data ( request -- request )
|
||||
[ >post-data ] change-post-data ;
|
||||
|
||||
: write-post-data ( request -- request )
|
||||
dup post-data>> [ write ] when* ;
|
||||
dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
|
||||
|
||||
: write-request ( request -- )
|
||||
unparse-post-data
|
||||
|
|
@ -307,7 +317,7 @@ body ;
|
|||
|
||||
: read-response-header
|
||||
read-header >>header
|
||||
extract-cookies
|
||||
dup "set-cookie" header parse-cookies >>cookies
|
||||
dup "content-type" header [
|
||||
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
|
||||
] when* ;
|
||||
|
|
|
|||
|
|
@ -35,8 +35,10 @@ IN: http.server.cgi
|
|||
request get "accept" header "HTTP_ACCEPT" set
|
||||
|
||||
post? [
|
||||
request get post-data-type>> "CONTENT_TYPE" set
|
||||
request get post-data>> length number>string "CONTENT_LENGTH" set
|
||||
request get post-data>> raw>>
|
||||
[ "CONTENT_TYPE" set ]
|
||||
[ length number>string "CONTENT_LENGTH" set ]
|
||||
bi
|
||||
] when
|
||||
] H{ } make-assoc ;
|
||||
|
||||
|
|
@ -51,7 +53,7 @@ IN: http.server.cgi
|
|||
"CGI output follows" >>message
|
||||
swap '[
|
||||
, output-stream get swap <cgi-process> <process-stream> [
|
||||
post? [ request get post-data>> write flush ] when
|
||||
post? [ request get post-data>> raw>> write flush ] when
|
||||
input-stream get swap (stream-copy)
|
||||
] with-stream
|
||||
] >>body ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces sequences assocs accessors
|
||||
http http.server http.server.responses ;
|
||||
USING: kernel namespaces sequences assocs accessors splitting
|
||||
unicode.case http http.server http.server.responses ;
|
||||
IN: http.server.dispatchers
|
||||
|
||||
TUPLE: dispatcher default responders ;
|
||||
|
|
@ -31,8 +31,11 @@ TUPLE: vhost-dispatcher default responders ;
|
|||
: <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 )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: http.server.redirection.tests
|
||||
USING: http http.server.redirection urls accessors
|
||||
namespaces tools.test ;
|
||||
namespaces tools.test present ;
|
||||
|
||||
\ relative-to-request must-infer
|
||||
|
||||
|
|
@ -15,34 +15,34 @@ namespaces tools.test ;
|
|||
request set
|
||||
|
||||
[ "http://www.apple.com:80/xxx/bar" ] [
|
||||
<url> relative-to-request url>string
|
||||
<url> relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/baz" ] [
|
||||
<url> "baz" >>path relative-to-request url>string
|
||||
<url> "baz" >>path relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/baz?c=d" ] [
|
||||
<url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
|
||||
<url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/bar?c=d" ] [
|
||||
<url> { { "c" "d" } } >>query relative-to-request url>string
|
||||
<url> { { "c" "d" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/flip" ] [
|
||||
<url> "/flip" >>path relative-to-request url>string
|
||||
<url> "/flip" >>path relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/flip?c=d" ] [
|
||||
<url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
|
||||
<url> "/flip" >>path { { "c" "d" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.jedit.org:80/" ] [
|
||||
"http://www.jedit.org" >url relative-to-request url>string
|
||||
"http://www.jedit.org" >url relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.jedit.org:80/?a=b" ] [
|
||||
"http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string
|
||||
"http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
USING: http http.server math sequences continuations tools.test ;
|
||||
IN: http.server.tests
|
||||
|
||||
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
|
||||
|
|
@ -22,7 +22,7 @@ C: <trivial-responder> trivial-responder
|
|||
|
||||
M: trivial-responder call-responder* nip response>> clone ;
|
||||
|
||||
main-responder global [ <404> <trivial-responder> get-global or ] change-at
|
||||
main-responder global [ <404> <trivial-responder> or ] change-at
|
||||
|
||||
: invert-slice ( slice -- slice' )
|
||||
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
|
||||
|
|
@ -40,7 +40,7 @@ main-responder global [ <404> <trivial-responder> get-global or ] change-at
|
|||
|
||||
: <500> ( error -- response )
|
||||
500 "Internal server error" <trivial-response>
|
||||
development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
|
||||
swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
|
||||
|
||||
: do-response ( response -- )
|
||||
dup write-response
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: peg peg.parsers kernel sequences strings words
|
||||
memoize ;
|
||||
USING: peg peg.parsers kernel sequences strings words ;
|
||||
IN: io.unix.launcher.parser
|
||||
|
||||
! Our command line parser. Supported syntax:
|
||||
|
|
@ -9,20 +8,20 @@ IN: io.unix.launcher.parser
|
|||
! foo\ bar -- escaping the space
|
||||
! 'foo bar' -- quotation
|
||||
! "foo bar" -- quotation
|
||||
MEMO: 'escaped-char' ( -- parser )
|
||||
"\\" token [ drop t ] satisfy 2seq [ second ] action ;
|
||||
: 'escaped-char' ( -- parser )
|
||||
"\\" token any-char 2seq [ second ] action ;
|
||||
|
||||
MEMO: 'quoted-char' ( delimiter -- parser' )
|
||||
: 'quoted-char' ( delimiter -- parser' )
|
||||
'escaped-char'
|
||||
swap [ member? not ] curry satisfy
|
||||
2choice ; inline
|
||||
|
||||
MEMO: 'quoted' ( delimiter -- parser )
|
||||
: 'quoted' ( delimiter -- parser )
|
||||
dup 'quoted-char' repeat0 swap dup surrounded-by ;
|
||||
|
||||
MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
|
||||
: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
|
||||
|
||||
MEMO: 'argument' ( -- parser )
|
||||
: 'argument' ( -- parser )
|
||||
"\"" 'quoted'
|
||||
"'" 'quoted'
|
||||
'unquoted' 3choice
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types colors jamshred.game jamshred.oint
|
||||
jamshred.player jamshred.tunnel kernel math math.vectors opengl
|
||||
opengl.gl opengl.glu sequences ;
|
||||
USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences ;
|
||||
IN: jamshred.gl
|
||||
|
||||
: min-vertices 6 ; inline
|
||||
|
|
@ -14,6 +12,35 @@ IN: jamshred.gl
|
|||
: n-segments-ahead ( -- n ) 60 ; inline
|
||||
: n-segments-behind ( -- n ) 40 ; inline
|
||||
|
||||
: wall-drawing-offset ( -- n )
|
||||
#! so that we can't see through the wall, we draw it a bit further away
|
||||
0.15 ;
|
||||
|
||||
: wall-drawing-radius ( segment -- r )
|
||||
radius>> wall-drawing-offset + ;
|
||||
|
||||
: wall-up ( segment -- v )
|
||||
[ wall-drawing-radius ] [ up>> ] bi n*v ;
|
||||
|
||||
: wall-left ( segment -- v )
|
||||
[ wall-drawing-radius ] [ left>> ] bi n*v ;
|
||||
|
||||
: segment-vertex ( theta segment -- vertex )
|
||||
[
|
||||
[ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
|
||||
] [
|
||||
location>> v+
|
||||
] bi ;
|
||||
|
||||
: segment-vertex-normal ( vertex segment -- normal )
|
||||
location>> swap v- normalize ;
|
||||
|
||||
: segment-vertex-and-normal ( segment theta -- vertex normal )
|
||||
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
|
||||
|
||||
: equally-spaced-radians ( n -- seq )
|
||||
#! return a sequence of n numbers between 0 and 2pi
|
||||
dup [ / pi 2 * * ] curry map ;
|
||||
: draw-segment-vertex ( segment theta -- )
|
||||
over segment-color gl-color segment-vertex-and-normal
|
||||
gl-normal gl-vertex ;
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ jamshred-gadget H{
|
|||
{ 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
|
||||
|
|
|
|||
|
|
@ -39,8 +39,11 @@ C: <oint> oint
|
|||
: random-turn ( oint theta -- )
|
||||
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
|
||||
|
||||
: location+ ( v oint -- )
|
||||
[ location>> v+ ] [ (>>location) ] bi ;
|
||||
|
||||
: go-forward ( distance oint -- )
|
||||
[ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
|
||||
[ forward>> n*v ] [ location+ ] bi ;
|
||||
|
||||
: distance-vector ( oint oint -- vector )
|
||||
[ location>> ] bi@ swap v- ;
|
||||
|
|
@ -62,3 +65,9 @@ C: <oint> oint
|
|||
:: reflect ( v n -- v' )
|
||||
#! bounce v on a surface with normal n
|
||||
v v n v. n n v. / 2 * n n*v v- ;
|
||||
|
||||
: half-way ( p1 p2 -- p3 )
|
||||
over v- 2 v/n v+ ;
|
||||
|
||||
: half-way-between-oints ( o1 o2 -- p )
|
||||
[ location>> ] bi@ half-way ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
|
||||
USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices shuffle sequences system ;
|
||||
USE: tools.walker
|
||||
IN: jamshred.player
|
||||
|
||||
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
||||
|
|
@ -30,6 +31,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
|||
[ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
|
||||
[ (>>nearest-segment) ] tri ;
|
||||
|
||||
: update-time ( player -- seconds-passed )
|
||||
millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
|
||||
|
||||
: moved ( player -- ) millis swap (>>last-move) ;
|
||||
|
||||
: speed-range ( -- range )
|
||||
|
|
@ -41,38 +45,82 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
|||
: multiply-player-speed ( n player -- )
|
||||
[ * speed-range clamp-to-range ] change-speed drop ;
|
||||
|
||||
: distance-to-move ( player -- distance )
|
||||
[ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
|
||||
[ (>>last-move) ] tri ;
|
||||
: distance-to-move ( seconds-passed player -- distance )
|
||||
speed>> * ;
|
||||
|
||||
DEFER: (move-player)
|
||||
: bounce ( d-left player -- d-left' player )
|
||||
{
|
||||
[ dup nearest-segment>> bounce-off-wall ]
|
||||
[ sounds>> bang ]
|
||||
[ 3/4 swap multiply-player-speed ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
: ?bounce ( distance-remaining player -- )
|
||||
:: (distance) ( heading player -- current next location heading )
|
||||
player nearest-segment>>
|
||||
player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
|
||||
player location>> heading ;
|
||||
|
||||
: distance-to-heading-segment ( heading player -- distance )
|
||||
(distance) distance-to-next-segment ;
|
||||
|
||||
: distance-to-heading-segment-area ( heading player -- distance )
|
||||
(distance) distance-to-next-segment-area ;
|
||||
|
||||
: distance-to-collision ( player -- distance )
|
||||
dup nearest-segment>> (distance-to-collision) ;
|
||||
|
||||
: from ( player -- radius distance-from-centre )
|
||||
[ nearest-segment>> dup radius>> swap ] [ location>> ] bi
|
||||
distance-from-centre ;
|
||||
|
||||
: distance-from-wall ( player -- distance ) from - ;
|
||||
: fraction-from-centre ( player -- fraction ) from swap / ;
|
||||
: fraction-from-wall ( player -- fraction )
|
||||
fraction-from-centre 1 swap - ;
|
||||
|
||||
: update-nearest-segment2 ( heading player -- )
|
||||
2dup distance-to-heading-segment-area 0 <= [
|
||||
[ tunnel>> ] [ nearest-segment>> rot heading-segment ]
|
||||
[ (>>nearest-segment) ] tri
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
:: move-player-on-heading ( d-left player distance heading -- d-left' player )
|
||||
[let* | d-to-move [ d-left distance min ]
|
||||
move-v [ d-to-move heading n*v ] |
|
||||
move-v player location+
|
||||
heading player update-nearest-segment2
|
||||
d-left d-to-move - player ] ;
|
||||
|
||||
: move-toward-wall ( d-left player d-to-wall -- d-left' player )
|
||||
over [ forward>> ] keep distance-to-heading-segment-area min
|
||||
over forward>> move-player-on-heading ;
|
||||
|
||||
: ?move-player-freely ( d-left player -- d-left' player )
|
||||
over 0 > [
|
||||
{
|
||||
[ dup nearest-segment>> bounce ]
|
||||
[ sounds>> bang ]
|
||||
[ 3/4 swap multiply-player-speed ]
|
||||
[ (move-player) ]
|
||||
} cleave
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
|
||||
move-toward-wall ?move-player-freely
|
||||
] [ drop ] if
|
||||
] when ;
|
||||
|
||||
: move-player-distance ( distance-remaining player distance -- distance-remaining player )
|
||||
pick min tuck over go-forward [ - ] dip ;
|
||||
: drag-heading ( player -- heading )
|
||||
[ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
|
||||
|
||||
: (move-player) ( distance-remaining player -- )
|
||||
over 0 <= [
|
||||
2drop
|
||||
] [
|
||||
dup dup nearest-segment>> distance-to-collision
|
||||
move-player-distance ?bounce
|
||||
] if ;
|
||||
: drag-player ( d-left player -- d-left' player )
|
||||
dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
|
||||
[ drag-heading move-player-on-heading ] bi ;
|
||||
|
||||
: (move-player) ( d-left player -- d-left' player )
|
||||
?move-player-freely over 0 > [
|
||||
! bounce
|
||||
drag-player
|
||||
(move-player)
|
||||
] when ;
|
||||
|
||||
: move-player ( player -- )
|
||||
[ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
|
||||
[ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
|
||||
|
||||
: update-player ( player -- )
|
||||
dup move-player nearest-segment>>
|
||||
white swap set-segment-color ;
|
||||
[ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
|
||||
|
|
|
|||
|
|
@ -42,4 +42,4 @@ IN: jamshred.tunnel.tests
|
|||
[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
|
||||
[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
|
||||
[ { 0 1 0 } ]
|
||||
[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test
|
||||
[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
|
||||
USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
|
||||
USE: tools.walker
|
||||
IN: jamshred.tunnel
|
||||
|
||||
: n-segments ( -- n ) 5000 ; inline
|
||||
|
|
@ -8,21 +9,6 @@ IN: jamshred.tunnel
|
|||
TUPLE: segment < oint number color radius ;
|
||||
C: <segment> segment
|
||||
|
||||
: segment-vertex ( theta segment -- vertex )
|
||||
tuck 2dup up>> swap sin v*n
|
||||
>r left>> swap cos v*n r> v+
|
||||
swap location>> v+ ;
|
||||
|
||||
: segment-vertex-normal ( vertex segment -- normal )
|
||||
location>> swap v- normalize ;
|
||||
|
||||
: segment-vertex-and-normal ( segment theta -- vertex normal )
|
||||
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
|
||||
|
||||
: equally-spaced-radians ( n -- seq )
|
||||
#! return a sequence of n numbers between 0 and 2pi
|
||||
dup [ / pi 2 * * ] curry map ;
|
||||
|
||||
: segment-number++ ( segment -- )
|
||||
[ number>> 1+ ] keep (>>number) ;
|
||||
|
||||
|
|
@ -40,9 +26,7 @@ C: <segment> segment
|
|||
: (random-segments) ( segments n -- segments )
|
||||
dup 0 > [
|
||||
>r dup peek random-segment over push r> 1- (random-segments)
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
] [ drop ] if ;
|
||||
|
||||
: default-segment-radius ( -- r ) 1 ;
|
||||
|
||||
|
|
@ -66,7 +50,7 @@ C: <segment> segment
|
|||
: <straight-tunnel> ( -- segments )
|
||||
n-segments simple-segments ;
|
||||
|
||||
: sub-tunnel ( from to sements -- segments )
|
||||
: sub-tunnel ( from to segments -- segments )
|
||||
#! return segments between from and to, after clamping from and to to
|
||||
#! valid values
|
||||
[ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
|
||||
|
|
@ -97,6 +81,32 @@ C: <segment> segment
|
|||
[ nearest-segment-forward ] 3keep
|
||||
nearest-segment-backward r> nearer-segment ;
|
||||
|
||||
: get-segment ( segments n -- segment )
|
||||
over sequence-index-range clamp-to-range swap nth ;
|
||||
|
||||
: next-segment ( segments current-segment -- segment )
|
||||
number>> 1+ get-segment ;
|
||||
|
||||
: previous-segment ( segments current-segment -- segment )
|
||||
number>> 1- get-segment ;
|
||||
|
||||
: heading-segment ( segments current-segment heading -- segment )
|
||||
#! the next segment on the given heading
|
||||
over forward>> v. 0 <=> {
|
||||
{ +gt+ [ next-segment ] }
|
||||
{ +lt+ [ previous-segment ] }
|
||||
{ +eq+ [ nip ] } ! current segment
|
||||
} case ;
|
||||
|
||||
:: distance-to-next-segment ( current next location heading -- distance )
|
||||
[let | cf [ current forward>> ] |
|
||||
cf next location>> v. cf location v. - cf heading v. / ] ;
|
||||
|
||||
:: distance-to-next-segment-area ( current next location heading -- distance )
|
||||
[let | cf [ current forward>> ]
|
||||
h [ next current half-way-between-oints ] |
|
||||
cf h v. cf location v. - cf heading v. / ] ;
|
||||
|
||||
: vector-to-centre ( seg loc -- v )
|
||||
over location>> swap v- swap forward>> proj-perp ;
|
||||
|
||||
|
|
@ -106,19 +116,25 @@ C: <segment> segment
|
|||
: wall-normal ( seg oint -- n )
|
||||
location>> vector-to-centre normalize ;
|
||||
|
||||
: from ( seg loc -- radius d-f-c )
|
||||
dupd location>> distance-from-centre [ radius>> ] dip ;
|
||||
: distant ( -- n ) 1000 ;
|
||||
|
||||
: distance-from-wall ( seg loc -- distance ) from - ;
|
||||
: fraction-from-centre ( seg loc -- fraction ) from / ;
|
||||
: fraction-from-wall ( seg loc -- fraction )
|
||||
fraction-from-centre 1 swap - ;
|
||||
: max-real ( a b -- c )
|
||||
#! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
|
||||
dup real? [
|
||||
over real? [ max ] [ nip ] if
|
||||
] [
|
||||
drop dup real? [ drop distant ] unless
|
||||
] if ;
|
||||
|
||||
:: collision-coefficient ( v w r -- c )
|
||||
[let* | a [ v dup v. ]
|
||||
b [ v w v. 2 * ]
|
||||
c [ w dup v. r sq - ] |
|
||||
c b a quadratic max ] ;
|
||||
v norm 0 = [
|
||||
distant
|
||||
] [
|
||||
[let* | a [ v dup v. ]
|
||||
b [ v w v. 2 * ]
|
||||
c [ w dup v. r sq - ] |
|
||||
c b a quadratic max-real ]
|
||||
] if ;
|
||||
|
||||
: sideways-heading ( oint segment -- v )
|
||||
[ forward>> ] bi@ proj-perp ;
|
||||
|
|
@ -126,18 +142,12 @@ C: <segment> segment
|
|||
: sideways-relative-location ( oint segment -- loc )
|
||||
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
|
||||
|
||||
: bounce-offset 0.1 ; inline
|
||||
|
||||
: bounce-radius ( segment -- r )
|
||||
radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?)
|
||||
: (distance-to-collision) ( oint segment -- distance )
|
||||
[ sideways-heading ] [ sideways-relative-location ]
|
||||
[ nip radius>> ] 2tri collision-coefficient ;
|
||||
|
||||
: collision-vector ( oint segment -- v )
|
||||
[ sideways-heading ] [ sideways-relative-location ]
|
||||
[ bounce-radius ] 2tri
|
||||
swap [ collision-coefficient ] dip forward>> n*v ;
|
||||
|
||||
: distance-to-collision ( oint segment -- distance )
|
||||
collision-vector norm ;
|
||||
dupd (distance-to-collision) swap forward>> n*v ;
|
||||
|
||||
: bounce-forward ( segment oint -- )
|
||||
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
|
||||
|
|
@ -151,6 +161,6 @@ C: <segment> segment
|
|||
#! must be done after forward and left!
|
||||
nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
|
||||
|
||||
: bounce ( oint segment -- )
|
||||
: bounce-off-wall ( oint segment -- )
|
||||
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel parser-combinators namespaces sequences promises strings
|
||||
assocs math math.parser math.vectors math.functions math.order
|
||||
lazy-lists hashtables ascii ;
|
||||
lists hashtables ascii ;
|
||||
IN: json.reader
|
||||
|
||||
! Grammar for JSON from RFC 4627
|
||||
|
|
|
|||
|
|
@ -1,445 +0,0 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Updated by Matthew Willis, July 2006
|
||||
! Updated by Chris Double, September 2006
|
||||
!
|
||||
USING: kernel sequences math vectors arrays namespaces
|
||||
quotations promises combinators io ;
|
||||
IN: lazy-lists
|
||||
|
||||
! Lazy List Protocol
|
||||
MIXIN: list
|
||||
GENERIC: car ( cons -- car )
|
||||
GENERIC: cdr ( cons -- cdr )
|
||||
GENERIC: nil? ( cons -- ? )
|
||||
|
||||
M: promise car ( promise -- car )
|
||||
force car ;
|
||||
|
||||
M: promise cdr ( promise -- cdr )
|
||||
force cdr ;
|
||||
|
||||
M: promise nil? ( cons -- bool )
|
||||
force nil? ;
|
||||
|
||||
TUPLE: cons car cdr ;
|
||||
|
||||
C: cons cons
|
||||
|
||||
M: cons car ( cons -- car )
|
||||
cons-car ;
|
||||
|
||||
M: cons cdr ( cons -- cdr )
|
||||
cons-cdr ;
|
||||
|
||||
: nil ( -- cons )
|
||||
T{ cons f f f } ;
|
||||
|
||||
M: cons nil? ( cons -- bool )
|
||||
nil eq? ;
|
||||
|
||||
: 1list ( obj -- cons )
|
||||
nil cons ;
|
||||
|
||||
: 2list ( a b -- cons )
|
||||
nil cons cons ;
|
||||
|
||||
: 3list ( a b c -- cons )
|
||||
nil cons cons cons ;
|
||||
|
||||
! Both 'car' and 'cdr' are promises
|
||||
TUPLE: lazy-cons car cdr ;
|
||||
|
||||
: lazy-cons ( car cdr -- promise )
|
||||
[ promise ] bi@ \ lazy-cons boa
|
||||
T{ promise f f t f } clone
|
||||
[ set-promise-value ] keep ;
|
||||
|
||||
M: lazy-cons car ( lazy-cons -- car )
|
||||
lazy-cons-car force ;
|
||||
|
||||
M: lazy-cons cdr ( lazy-cons -- cdr )
|
||||
lazy-cons-cdr force ;
|
||||
|
||||
M: lazy-cons nil? ( lazy-cons -- bool )
|
||||
nil eq? ;
|
||||
|
||||
: 1lazy-list ( a -- lazy-cons )
|
||||
[ nil ] lazy-cons ;
|
||||
|
||||
: 2lazy-list ( a b -- lazy-cons )
|
||||
1lazy-list 1quotation lazy-cons ;
|
||||
|
||||
: 3lazy-list ( a b c -- lazy-cons )
|
||||
2lazy-list 1quotation lazy-cons ;
|
||||
|
||||
: lnth ( n list -- elt )
|
||||
swap [ cdr ] times car ;
|
||||
|
||||
: (llength) ( list acc -- n )
|
||||
over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
|
||||
|
||||
: llength ( list -- n )
|
||||
0 (llength) ;
|
||||
|
||||
: uncons ( cons -- car cdr )
|
||||
#! Return the car and cdr of the lazy list
|
||||
dup car swap cdr ;
|
||||
|
||||
: leach ( list quot -- )
|
||||
swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
|
||||
|
||||
: lreduce ( list identity quot -- result )
|
||||
swapd leach ; inline
|
||||
|
||||
TUPLE: memoized-cons original car cdr nil? ;
|
||||
|
||||
: not-memoized ( -- obj )
|
||||
{ } ;
|
||||
|
||||
: not-memoized? ( obj -- bool )
|
||||
not-memoized eq? ;
|
||||
|
||||
: <memoized-cons> ( cons -- memoized-cons )
|
||||
not-memoized not-memoized not-memoized
|
||||
memoized-cons boa ;
|
||||
|
||||
M: memoized-cons car ( memoized-cons -- car )
|
||||
dup memoized-cons-car not-memoized? [
|
||||
dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
|
||||
] [
|
||||
memoized-cons-car
|
||||
] if ;
|
||||
|
||||
M: memoized-cons cdr ( memoized-cons -- cdr )
|
||||
dup memoized-cons-cdr not-memoized? [
|
||||
dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
|
||||
] [
|
||||
memoized-cons-cdr
|
||||
] if ;
|
||||
|
||||
M: memoized-cons nil? ( memoized-cons -- bool )
|
||||
dup memoized-cons-nil? not-memoized? [
|
||||
dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
|
||||
] [
|
||||
memoized-cons-nil?
|
||||
] if ;
|
||||
|
||||
TUPLE: lazy-map cons quot ;
|
||||
|
||||
C: <lazy-map> lazy-map
|
||||
|
||||
: lmap ( list quot -- result )
|
||||
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
|
||||
|
||||
M: lazy-map car ( lazy-map -- car )
|
||||
[ lazy-map-cons car ] keep
|
||||
lazy-map-quot call ;
|
||||
|
||||
M: lazy-map cdr ( lazy-map -- cdr )
|
||||
[ lazy-map-cons cdr ] keep
|
||||
lazy-map-quot lmap ;
|
||||
|
||||
M: lazy-map nil? ( lazy-map -- bool )
|
||||
lazy-map-cons nil? ;
|
||||
|
||||
: lmap-with ( value list quot -- result )
|
||||
with lmap ;
|
||||
|
||||
TUPLE: lazy-take n cons ;
|
||||
|
||||
C: <lazy-take> lazy-take
|
||||
|
||||
: ltake ( n list -- result )
|
||||
over zero? [ 2drop nil ] [ <lazy-take> ] if ;
|
||||
|
||||
M: lazy-take car ( lazy-take -- car )
|
||||
lazy-take-cons car ;
|
||||
|
||||
M: lazy-take cdr ( lazy-take -- cdr )
|
||||
[ lazy-take-n 1- ] keep
|
||||
lazy-take-cons cdr ltake ;
|
||||
|
||||
M: lazy-take nil? ( lazy-take -- bool )
|
||||
dup lazy-take-n zero? [
|
||||
drop t
|
||||
] [
|
||||
lazy-take-cons nil?
|
||||
] if ;
|
||||
|
||||
TUPLE: lazy-until cons quot ;
|
||||
|
||||
C: <lazy-until> lazy-until
|
||||
|
||||
: luntil ( list quot -- result )
|
||||
over nil? [ drop ] [ <lazy-until> ] if ;
|
||||
|
||||
M: lazy-until car ( lazy-until -- car )
|
||||
lazy-until-cons car ;
|
||||
|
||||
M: lazy-until cdr ( lazy-until -- cdr )
|
||||
[ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
|
||||
[ 2drop nil ] [ luntil ] if ;
|
||||
|
||||
M: lazy-until nil? ( lazy-until -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-while cons quot ;
|
||||
|
||||
C: <lazy-while> lazy-while
|
||||
|
||||
: lwhile ( list quot -- result )
|
||||
over nil? [ drop ] [ <lazy-while> ] if ;
|
||||
|
||||
M: lazy-while car ( lazy-while -- car )
|
||||
lazy-while-cons car ;
|
||||
|
||||
M: lazy-while cdr ( lazy-while -- cdr )
|
||||
[ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
|
||||
|
||||
M: lazy-while nil? ( lazy-while -- bool )
|
||||
[ car ] keep lazy-while-quot call not ;
|
||||
|
||||
TUPLE: lazy-filter cons quot ;
|
||||
|
||||
C: <lazy-filter> lazy-filter
|
||||
|
||||
: lfilter ( list quot -- result )
|
||||
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
|
||||
|
||||
: car-filter? ( lazy-filter -- ? )
|
||||
[ lazy-filter-cons car ] keep
|
||||
lazy-filter-quot call ;
|
||||
|
||||
: skip ( lazy-filter -- )
|
||||
[ lazy-filter-cons cdr ] keep
|
||||
set-lazy-filter-cons ;
|
||||
|
||||
M: lazy-filter car ( lazy-filter -- car )
|
||||
dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
|
||||
|
||||
M: lazy-filter cdr ( lazy-filter -- cdr )
|
||||
dup car-filter? [
|
||||
[ lazy-filter-cons cdr ] keep
|
||||
lazy-filter-quot lfilter
|
||||
] [
|
||||
dup skip cdr
|
||||
] if ;
|
||||
|
||||
M: lazy-filter nil? ( lazy-filter -- bool )
|
||||
dup lazy-filter-cons nil? [
|
||||
drop t
|
||||
] [
|
||||
dup car-filter? [
|
||||
drop f
|
||||
] [
|
||||
dup skip nil?
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: list>vector ( list -- vector )
|
||||
[ [ , ] leach ] V{ } make ;
|
||||
|
||||
: list>array ( list -- array )
|
||||
[ [ , ] leach ] { } make ;
|
||||
|
||||
TUPLE: lazy-append list1 list2 ;
|
||||
|
||||
C: <lazy-append> lazy-append
|
||||
|
||||
: lappend ( list1 list2 -- result )
|
||||
over nil? [ nip ] [ <lazy-append> ] if ;
|
||||
|
||||
M: lazy-append car ( lazy-append -- car )
|
||||
lazy-append-list1 car ;
|
||||
|
||||
M: lazy-append cdr ( lazy-append -- cdr )
|
||||
[ lazy-append-list1 cdr ] keep
|
||||
lazy-append-list2 lappend ;
|
||||
|
||||
M: lazy-append nil? ( lazy-append -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-from-by n quot ;
|
||||
|
||||
C: lfrom-by lazy-from-by ( n quot -- list )
|
||||
|
||||
: lfrom ( n -- list )
|
||||
[ 1+ ] lfrom-by ;
|
||||
|
||||
M: lazy-from-by car ( lazy-from-by -- car )
|
||||
lazy-from-by-n ;
|
||||
|
||||
M: lazy-from-by cdr ( lazy-from-by -- cdr )
|
||||
[ lazy-from-by-n ] keep
|
||||
lazy-from-by-quot dup slip lfrom-by ;
|
||||
|
||||
M: lazy-from-by nil? ( lazy-from-by -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-zip list1 list2 ;
|
||||
|
||||
C: <lazy-zip> lazy-zip
|
||||
|
||||
: lzip ( list1 list2 -- lazy-zip )
|
||||
over nil? over nil? or
|
||||
[ 2drop nil ] [ <lazy-zip> ] if ;
|
||||
|
||||
M: lazy-zip car ( lazy-zip -- car )
|
||||
[ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
|
||||
|
||||
M: lazy-zip cdr ( lazy-zip -- cdr )
|
||||
[ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
|
||||
|
||||
M: lazy-zip nil? ( lazy-zip -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: sequence-cons index seq ;
|
||||
|
||||
C: <sequence-cons> sequence-cons
|
||||
|
||||
: seq>list ( index seq -- list )
|
||||
2dup length >= [
|
||||
2drop nil
|
||||
] [
|
||||
<sequence-cons>
|
||||
] if ;
|
||||
|
||||
M: sequence-cons car ( sequence-cons -- car )
|
||||
[ sequence-cons-index ] keep
|
||||
sequence-cons-seq nth ;
|
||||
|
||||
M: sequence-cons cdr ( sequence-cons -- cdr )
|
||||
[ sequence-cons-index 1+ ] keep
|
||||
sequence-cons-seq seq>list ;
|
||||
|
||||
M: sequence-cons nil? ( sequence-cons -- bool )
|
||||
drop f ;
|
||||
|
||||
: >list ( object -- list )
|
||||
{
|
||||
{ [ dup sequence? ] [ 0 swap seq>list ] }
|
||||
{ [ dup list? ] [ ] }
|
||||
[ "Could not convert object to a list" throw ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: lazy-concat car cdr ;
|
||||
|
||||
C: <lazy-concat> lazy-concat
|
||||
|
||||
DEFER: lconcat
|
||||
|
||||
: (lconcat) ( car cdr -- list )
|
||||
over nil? [
|
||||
nip lconcat
|
||||
] [
|
||||
<lazy-concat>
|
||||
] if ;
|
||||
|
||||
: lconcat ( list -- result )
|
||||
dup nil? [
|
||||
drop nil
|
||||
] [
|
||||
uncons (lconcat)
|
||||
] if ;
|
||||
|
||||
M: lazy-concat car ( lazy-concat -- car )
|
||||
lazy-concat-car car ;
|
||||
|
||||
M: lazy-concat cdr ( lazy-concat -- cdr )
|
||||
[ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
|
||||
|
||||
M: lazy-concat nil? ( lazy-concat -- bool )
|
||||
dup lazy-concat-car nil? [
|
||||
lazy-concat-cdr nil?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: lcartesian-product ( list1 list2 -- result )
|
||||
swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
|
||||
|
||||
: lcartesian-product* ( lists -- result )
|
||||
dup nil? [
|
||||
drop nil
|
||||
] [
|
||||
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
|
||||
swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
|
||||
] reduce
|
||||
] if ;
|
||||
|
||||
: lcomp ( list quot -- result )
|
||||
[ lcartesian-product* ] dip lmap ;
|
||||
|
||||
: lcomp* ( list guards quot -- result )
|
||||
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
|
||||
|
||||
DEFER: lmerge
|
||||
|
||||
: (lmerge) ( list1 list2 -- result )
|
||||
over [ car ] curry -rot
|
||||
[
|
||||
dup [ car ] curry -rot
|
||||
[
|
||||
[ cdr ] bi@ lmerge
|
||||
] 2curry lazy-cons
|
||||
] 2curry lazy-cons ;
|
||||
|
||||
: lmerge ( list1 list2 -- result )
|
||||
{
|
||||
{ [ over nil? ] [ nip ] }
|
||||
{ [ dup nil? ] [ drop ] }
|
||||
{ [ t ] [ (lmerge) ] }
|
||||
} cond ;
|
||||
|
||||
TUPLE: lazy-io stream car cdr quot ;
|
||||
|
||||
C: <lazy-io> lazy-io
|
||||
|
||||
: lcontents ( stream -- result )
|
||||
f f [ stream-read1 ] <lazy-io> ;
|
||||
|
||||
: llines ( stream -- result )
|
||||
f f [ stream-readln ] <lazy-io> ;
|
||||
|
||||
M: lazy-io car ( lazy-io -- car )
|
||||
dup lazy-io-car dup [
|
||||
nip
|
||||
] [
|
||||
drop dup lazy-io-stream over lazy-io-quot call
|
||||
swap dupd set-lazy-io-car
|
||||
] if ;
|
||||
|
||||
M: lazy-io cdr ( lazy-io -- cdr )
|
||||
dup lazy-io-cdr dup [
|
||||
nip
|
||||
] [
|
||||
drop dup
|
||||
[ lazy-io-stream ] keep
|
||||
[ lazy-io-quot ] keep
|
||||
car [
|
||||
[ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
|
||||
] [
|
||||
3drop nil
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: lazy-io nil? ( lazy-io -- bool )
|
||||
car not ;
|
||||
|
||||
INSTANCE: cons list
|
||||
INSTANCE: sequence-cons list
|
||||
INSTANCE: memoized-cons list
|
||||
INSTANCE: promise list
|
||||
INSTANCE: lazy-io list
|
||||
INSTANCE: lazy-concat list
|
||||
INSTANCE: lazy-cons list
|
||||
INSTANCE: lazy-map list
|
||||
INSTANCE: lazy-take list
|
||||
INSTANCE: lazy-append list
|
||||
INSTANCE: lazy-from-by list
|
||||
INSTANCE: lazy-zip list
|
||||
INSTANCE: lazy-while list
|
||||
INSTANCE: lazy-until list
|
||||
INSTANCE: lazy-filter list
|
||||
|
|
@ -1,17 +1,19 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lisp lisp.parser tools.test sequences math kernel parser ;
|
||||
USING: lisp lisp.parser tools.test sequences math kernel parser arrays ;
|
||||
|
||||
IN: lisp.test
|
||||
|
||||
[
|
||||
init-env
|
||||
|
||||
"#f" [ f ] lisp-define
|
||||
"#t" [ t ] lisp-define
|
||||
[ f ] "#f" lisp-define
|
||||
[ t ] "#t" lisp-define
|
||||
|
||||
"+" "math" "+" define-primitve
|
||||
"-" "math" "-" define-primitve
|
||||
"+" "math" "+" define-primitive
|
||||
"-" "math" "-" define-primitive
|
||||
|
||||
! "list" [ >array ] lisp-define
|
||||
|
||||
{ 5 } [
|
||||
[ 2 3 ] "+" <lisp-symbol> funcall
|
||||
|
|
@ -22,26 +24,39 @@ IN: lisp.test
|
|||
] unit-test
|
||||
|
||||
{ 3 } [
|
||||
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
|
||||
"((lambda (x y) (+ x y)) 1 2)" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ 42 } [
|
||||
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call
|
||||
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ T{ lisp-symbol f "if" } } [
|
||||
"(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
T{ lisp-symbol f "if" } lisp-macro?
|
||||
] unit-test
|
||||
|
||||
{ 1 } [
|
||||
"(if #t 1 2)" lisp-string>factor call
|
||||
"(if #t 1 2)" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ "b" } [
|
||||
"(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
|
||||
"(cond (#f \"a\") (#t \"b\"))" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ 5 } [
|
||||
"(begin (+ 1 4))" lisp-string>factor call
|
||||
"(begin (+ 1 4))" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ 3 } [
|
||||
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
|
||||
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
|
||||
] unit-test
|
||||
] with-interactive-vocabs
|
||||
|
||||
! { { 1 2 3 4 5 } } [
|
||||
! "(list 1 2 3 4 5)" lisp-eval
|
||||
! ] unit-test
|
||||
|
||||
] with-interactive-vocabs
|
||||
|
|
|
|||
|
|
@ -1,48 +1,47 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel peg sequences arrays strings combinators.lib
|
||||
namespaces combinators math bake locals locals.private accessors
|
||||
vectors syntax lisp.parser assocs parser sequences.lib words quotations
|
||||
fry ;
|
||||
namespaces combinators math locals locals.private accessors
|
||||
vectors syntax lisp.parser assocs parser sequences.lib words
|
||||
quotations fry lists inspector ;
|
||||
IN: lisp
|
||||
|
||||
DEFER: convert-form
|
||||
DEFER: funcall
|
||||
DEFER: lookup-var
|
||||
|
||||
DEFER: lookup-macro
|
||||
DEFER: lisp-macro?
|
||||
DEFER: macro-expand
|
||||
DEFER: define-lisp-macro
|
||||
|
||||
! Functions to convert s-exps to quotations
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: convert-body ( s-exp -- quot )
|
||||
[ ] [ convert-form compose ] reduce ; inline
|
||||
|
||||
: convert-if ( s-exp -- quot )
|
||||
rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
|
||||
: convert-body ( cons -- quot )
|
||||
[ ] [ convert-form compose ] foldl ; inline
|
||||
|
||||
: convert-begin ( s-exp -- quot )
|
||||
rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ;
|
||||
: convert-begin ( cons -- quot )
|
||||
cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
|
||||
|
||||
: convert-cond ( s-exp -- quot )
|
||||
rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
|
||||
{ } map-as '[ , cond ] ;
|
||||
: convert-cond ( cons -- quot )
|
||||
cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
|
||||
{ } lmap-as '[ , cond ] ;
|
||||
|
||||
: convert-general-form ( s-exp -- quot )
|
||||
unclip convert-form swap convert-body swap '[ , @ funcall ] ;
|
||||
: convert-general-form ( cons -- quot )
|
||||
uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ;
|
||||
|
||||
! words for convert-lambda
|
||||
<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 ;
|
||||
|
||||
[ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
|
||||
|
||||
: localize-lambda ( body vars -- newbody newvars )
|
||||
make-locals dup push-locals swap
|
||||
[ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
|
||||
[ swap localize-body convert-form swap pop-locals ] dip swap ;
|
||||
|
||||
: split-lambda ( s-exp -- body vars )
|
||||
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 ] ;
|
||||
|
|
@ -51,46 +50,80 @@ DEFER: lookup-var
|
|||
localize-lambda <lambda> '[ , compose ] ;
|
||||
PRIVATE>
|
||||
|
||||
: convert-lambda ( s-exp -- quot )
|
||||
: convert-lambda ( cons -- quot )
|
||||
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
|
||||
|
||||
: convert-quoted ( s-exp -- quot )
|
||||
second 1quotation ;
|
||||
: convert-quoted ( cons -- quot )
|
||||
cdr 1quotation ;
|
||||
|
||||
: convert-list-form ( s-exp -- quot )
|
||||
dup first dup lisp-symbol?
|
||||
[ name>>
|
||||
{ { "lambda" [ convert-lambda ] }
|
||||
{ "quote" [ convert-quoted ] }
|
||||
{ "if" [ convert-if ] }
|
||||
{ "begin" [ convert-begin ] }
|
||||
{ "cond" [ convert-cond ] }
|
||||
[ drop convert-general-form ]
|
||||
} case ]
|
||||
[ drop convert-general-form ] if ;
|
||||
: convert-unquoted ( cons -- quot )
|
||||
"unquote not valid outside of quasiquote!" throw ;
|
||||
|
||||
: convert-form ( lisp-form -- quot )
|
||||
{ { [ dup s-exp? ] [ body>> convert-list-form ] }
|
||||
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
|
||||
[ 1quotation ]
|
||||
: convert-quasiquoted ( cons -- newcons )
|
||||
[ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
|
||||
[ cadr ] traverse ;
|
||||
|
||||
: convert-defmacro ( cons -- quot )
|
||||
cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
|
||||
|
||||
: form-dispatch ( cons lisp-symbol -- quot )
|
||||
name>>
|
||||
{ { "lambda" [ convert-lambda ] }
|
||||
{ "defmacro" [ convert-defmacro ] }
|
||||
{ "quote" [ convert-quoted ] }
|
||||
{ "unquote" [ convert-unquoted ] }
|
||||
{ "quasiquote" [ convert-quasiquoted ] }
|
||||
{ "begin" [ convert-begin ] }
|
||||
{ "cond" [ convert-cond ] }
|
||||
[ drop convert-general-form ]
|
||||
} case ;
|
||||
|
||||
: convert-list-form ( cons -- quot )
|
||||
dup car
|
||||
{ { [ dup lisp-macro? ] [ drop macro-expand ] }
|
||||
{ [ dup lisp-symbol? ] [ form-dispatch ] }
|
||||
[ drop convert-general-form ]
|
||||
} cond ;
|
||||
|
||||
: convert-form ( lisp-form -- quot )
|
||||
{
|
||||
{ [ dup cons? ] [ convert-list-form ] }
|
||||
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
|
||||
[ 1quotation ]
|
||||
} cond ;
|
||||
|
||||
: compile-form ( lisp-ast -- quot )
|
||||
convert-form lambda-rewrite call ; inline
|
||||
|
||||
: macro-call ( lambda -- cons )
|
||||
call ; inline
|
||||
|
||||
: macro-expand ( cons -- quot )
|
||||
uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* call ;
|
||||
|
||||
: lisp-string>factor ( str -- quot )
|
||||
lisp-expr parse-result-ast convert-form lambda-rewrite call ;
|
||||
lisp-expr parse-result-ast compile-form ;
|
||||
|
||||
: lisp-eval ( str -- * )
|
||||
lisp-string>factor call ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: lisp-env
|
||||
ERROR: no-such-var var ;
|
||||
SYMBOL: macro-env
|
||||
|
||||
ERROR: no-such-var variable-name ;
|
||||
M: no-such-var summary drop "No such variable" ;
|
||||
|
||||
: init-env ( -- )
|
||||
H{ } clone lisp-env set ;
|
||||
H{ } clone lisp-env set
|
||||
H{ } clone macro-env set ;
|
||||
|
||||
: lisp-define ( name quot -- )
|
||||
swap lisp-env get set-at ;
|
||||
: lisp-define ( quot name -- )
|
||||
lisp-env get set-at ;
|
||||
|
||||
: lisp-get ( name -- word )
|
||||
dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
|
||||
dup lisp-env get at [ ] [ no-such-var ] ?if ;
|
||||
|
||||
: lookup-var ( lisp-symbol -- quot )
|
||||
name>> lisp-get ;
|
||||
|
|
@ -98,5 +131,14 @@ ERROR: no-such-var var ;
|
|||
: funcall ( quot sym -- * )
|
||||
dup lisp-symbol? [ lookup-var ] when call ; inline
|
||||
|
||||
: define-primitve ( name vocab word -- )
|
||||
swap lookup 1quotation '[ , compose call ] lisp-define ;
|
||||
: define-primitive ( name vocab word -- )
|
||||
swap lookup 1quotation '[ , compose call ] swap lisp-define ;
|
||||
|
||||
: lookup-macro ( lisp-symbol -- lambda )
|
||||
name>> macro-env get at ;
|
||||
|
||||
: define-lisp-macro ( quot name -- )
|
||||
macro-env get set-at ;
|
||||
|
||||
: lisp-macro? ( car -- ? )
|
||||
dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lisp.parser tools.test peg peg.ebnf ;
|
||||
USING: lisp.parser tools.test peg peg.ebnf lists ;
|
||||
|
||||
IN: lisp.parser.tests
|
||||
|
||||
|
|
@ -9,38 +9,60 @@ IN: lisp.parser.tests
|
|||
] unit-test
|
||||
|
||||
{ -42 } [
|
||||
"-42" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"-42" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ 37/52 } [
|
||||
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ 123.98 } [
|
||||
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "" } [
|
||||
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "aoeu" } [
|
||||
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "aoeu\"de" } [
|
||||
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ lisp-symbol f "foobar" } } [
|
||||
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ lisp-symbol f "+" } } [
|
||||
"+" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"+" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ s-exp f
|
||||
V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
|
||||
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
|
||||
{ +nil+ } [
|
||||
"()" lisp-expr parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{
|
||||
cons
|
||||
f
|
||||
T{ lisp-symbol f "foo" }
|
||||
T{
|
||||
cons
|
||||
f
|
||||
1
|
||||
T{ cons f 2 T{ cons f "aoeu" +nil+ } }
|
||||
} } } [
|
||||
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ cons f
|
||||
1
|
||||
T{ cons f
|
||||
T{ cons f 3 T{ cons f 4 +nil+ } }
|
||||
T{ cons f 2 +nil+ } }
|
||||
}
|
||||
} [
|
||||
"(1 (3 4) 2)" lisp-expr parse-result-ast
|
||||
] unit-test
|
||||
|
|
@ -1,16 +1,13 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
|
||||
combinators.lib math ;
|
||||
USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
|
||||
combinators.lib math fry accessors lists ;
|
||||
|
||||
IN: lisp.parser
|
||||
|
||||
TUPLE: lisp-symbol name ;
|
||||
C: <lisp-symbol> lisp-symbol
|
||||
|
||||
TUPLE: s-exp body ;
|
||||
C: <s-exp> s-exp
|
||||
|
||||
EBNF: lisp-expr
|
||||
_ = (" " | "\t" | "\n")*
|
||||
LPAREN = "("
|
||||
|
|
@ -24,8 +21,9 @@ rational = integer "/" (digit)+ => [[ first3 nip string
|
|||
number = float
|
||||
| rational
|
||||
| integer
|
||||
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
|
||||
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
|
||||
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
|
||||
| "<" | "#" | " =" | ">" | "?" | "^" | "_"
|
||||
| "~" | "+" | "-" | "." | "@"
|
||||
letters = [a-zA-Z] => [[ 1array >string ]]
|
||||
initials = letters | id-specials
|
||||
numbers = [0-9] => [[ 1array >string ]]
|
||||
|
|
@ -36,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
|
|||
atom = number
|
||||
| identifier
|
||||
| string
|
||||
list-item = _ (atom|s-expression) _ => [[ second ]]
|
||||
s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
|
||||
list-item = _ ( atom | s-expression ) _ => [[ second ]]
|
||||
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
|
||||
;EBNF
|
||||
|
|
@ -0,0 +1 @@
|
|||
James Cash
|
||||
|
|
@ -2,8 +2,8 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: lazy-lists math kernel sequences quotations ;
|
||||
IN: lazy-lists.examples
|
||||
USING: lists.lazy math kernel sequences quotations ;
|
||||
IN: lists.lazy.examples
|
||||
|
||||
: naturals 0 lfrom ;
|
||||
: positives 1 lfrom ;
|
||||
|
|
@ -11,5 +11,5 @@ IN: lazy-lists.examples
|
|||
: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
|
||||
: powers-of-2 1 [ 2 * ] lfrom-by ;
|
||||
: ones 1 [ ] lfrom-by ;
|
||||
: squares naturals [ dup * ] lmap ;
|
||||
: squares naturals [ dup * ] lazy-map ;
|
||||
: first-five-squares 5 squares ltake list>array ;
|
||||
|
|
@ -1,48 +1,8 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: help.markup help.syntax sequences strings ;
|
||||
IN: lazy-lists
|
||||
|
||||
{ car cons cdr nil nil? list? uncons } related-words
|
||||
|
||||
HELP: cons
|
||||
{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
|
||||
{ $description "Constructs a cons cell." } ;
|
||||
|
||||
HELP: car
|
||||
{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
|
||||
{ $description "Returns the first item in the list." } ;
|
||||
|
||||
HELP: cdr
|
||||
{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
|
||||
{ $description "Returns the tail of the list." } ;
|
||||
|
||||
HELP: nil
|
||||
{ $values { "cons" "An empty cons" } }
|
||||
{ $description "Returns a representation of an empty list" } ;
|
||||
|
||||
HELP: nil?
|
||||
{ $values { "cons" "a cons object" } { "?" "a boolean" } }
|
||||
{ $description "Return true if the cons object is the nil cons." } ;
|
||||
|
||||
HELP: list? ( object -- ? )
|
||||
{ $values { "object" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Returns true if the object conforms to the list protocol." } ;
|
||||
|
||||
{ 1list 2list 3list } related-words
|
||||
|
||||
HELP: 1list
|
||||
{ $values { "obj" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 1 element." } ;
|
||||
|
||||
HELP: 2list
|
||||
{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 2 elements." } ;
|
||||
|
||||
HELP: 3list
|
||||
{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 3 elements." } ;
|
||||
USING: help.markup help.syntax sequences strings lists ;
|
||||
IN: lists.lazy
|
||||
|
||||
HELP: lazy-cons
|
||||
{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
|
||||
|
|
@ -68,37 +28,15 @@ HELP: <memoized-cons>
|
|||
{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
|
||||
{ $see-also cons car cdr nil nil? } ;
|
||||
|
||||
HELP: lnth
|
||||
{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
|
||||
{ $description "Outputs the nth element of the list." }
|
||||
{ $see-also llength cons car cdr } ;
|
||||
{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
|
||||
|
||||
HELP: llength
|
||||
{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
|
||||
{ $description "Outputs the length of the list. This should not be called on an infinite list." }
|
||||
{ $see-also lnth cons car cdr } ;
|
||||
|
||||
HELP: uncons
|
||||
{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
|
||||
{ $description "Put the head and tail of the list on the stack." } ;
|
||||
|
||||
{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
|
||||
|
||||
HELP: leach
|
||||
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
|
||||
{ $description "Call the quotation for each item in the list." } ;
|
||||
|
||||
HELP: lreduce
|
||||
{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
|
||||
{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
|
||||
|
||||
HELP: lmap
|
||||
HELP: lazy-map
|
||||
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
|
||||
{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
|
||||
|
||||
HELP: lmap-with
|
||||
HELP: lazy-map-with
|
||||
{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
|
||||
{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;
|
||||
{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
|
||||
|
||||
HELP: ltake
|
||||
{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
|
||||
|
|
@ -147,6 +85,8 @@ HELP: >list
|
|||
{ $values { "object" "an object" } { "list" "a list" } }
|
||||
{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
|
||||
{ $see-also seq>list } ;
|
||||
|
||||
{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
|
||||
|
||||
HELP: lconcat
|
||||
{ $values { "list" "a list of lists" } { "result" "a list" } }
|
||||
|
|
@ -175,7 +115,7 @@ HELP: lmerge
|
|||
{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
|
||||
{ $description "Return the result of merging the two lists in a lazy manner." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
|
||||
{ $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
|
||||
} ;
|
||||
|
||||
HELP: lcontents
|
||||
|
|
@ -187,4 +127,3 @@ HELP: llines
|
|||
{ $values { "stream" "a stream" } { "result" "a list" } }
|
||||
{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
|
||||
{ $see-also lcontents } ;
|
||||
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006 Matthew Willis and Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: lazy-lists tools.test kernel math io sequences ;
|
||||
IN: lazy-lists.tests
|
||||
USING: lists lists.lazy tools.test kernel math io sequences ;
|
||||
IN: lists.lazy.tests
|
||||
|
||||
[ { 1 2 3 4 } ] [
|
||||
{ 1 2 3 4 } >list list>array
|
||||
|
|
@ -25,5 +25,5 @@ IN: lazy-lists.tests
|
|||
] unit-test
|
||||
|
||||
[ { 4 5 6 } ] [
|
||||
3 { 1 2 3 } >list [ + ] lmap-with list>array
|
||||
3 { 1 2 3 } >list [ + ] lazy-map-with list>array
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,392 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Updated by Matthew Willis, July 2006
|
||||
! Updated by Chris Double, September 2006
|
||||
! Updated by James Cash, June 2008
|
||||
!
|
||||
USING: kernel sequences math vectors arrays namespaces
|
||||
quotations promises combinators io lists accessors ;
|
||||
IN: lists.lazy
|
||||
|
||||
M: promise car ( promise -- car )
|
||||
force car ;
|
||||
|
||||
M: promise cdr ( promise -- cdr )
|
||||
force cdr ;
|
||||
|
||||
M: promise nil? ( cons -- bool )
|
||||
force nil? ;
|
||||
|
||||
! Both 'car' and 'cdr' are promises
|
||||
TUPLE: lazy-cons car cdr ;
|
||||
|
||||
: lazy-cons ( car cdr -- promise )
|
||||
[ promise ] bi@ \ lazy-cons boa
|
||||
T{ promise f f t f } clone
|
||||
[ set-promise-value ] keep ;
|
||||
|
||||
M: lazy-cons car ( lazy-cons -- car )
|
||||
car>> force ;
|
||||
|
||||
M: lazy-cons cdr ( lazy-cons -- cdr )
|
||||
cdr>> force ;
|
||||
|
||||
M: lazy-cons nil? ( lazy-cons -- bool )
|
||||
nil eq? ;
|
||||
|
||||
: 1lazy-list ( a -- lazy-cons )
|
||||
[ nil ] lazy-cons ;
|
||||
|
||||
: 2lazy-list ( a b -- lazy-cons )
|
||||
1lazy-list 1quotation lazy-cons ;
|
||||
|
||||
: 3lazy-list ( a b c -- lazy-cons )
|
||||
2lazy-list 1quotation lazy-cons ;
|
||||
|
||||
TUPLE: memoized-cons original car cdr nil? ;
|
||||
|
||||
: not-memoized ( -- obj )
|
||||
{ } ;
|
||||
|
||||
: not-memoized? ( obj -- bool )
|
||||
not-memoized eq? ;
|
||||
|
||||
: <memoized-cons> ( cons -- memoized-cons )
|
||||
not-memoized not-memoized not-memoized
|
||||
memoized-cons boa ;
|
||||
|
||||
M: memoized-cons car ( memoized-cons -- car )
|
||||
dup car>> not-memoized? [
|
||||
dup original>> car [ >>car drop ] keep
|
||||
] [
|
||||
car>>
|
||||
] if ;
|
||||
|
||||
M: memoized-cons cdr ( memoized-cons -- cdr )
|
||||
dup cdr>> not-memoized? [
|
||||
dup original>> cdr [ >>cdr drop ] keep
|
||||
] [
|
||||
cdr>>
|
||||
] if ;
|
||||
|
||||
M: memoized-cons nil? ( memoized-cons -- bool )
|
||||
dup nil?>> not-memoized? [
|
||||
dup original>> nil? [ >>nil? drop ] keep
|
||||
] [
|
||||
nil?>>
|
||||
] if ;
|
||||
|
||||
TUPLE: lazy-map cons quot ;
|
||||
|
||||
C: <lazy-map> lazy-map
|
||||
|
||||
: lazy-map ( list quot -- result )
|
||||
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
|
||||
|
||||
M: lazy-map car ( lazy-map -- car )
|
||||
[ cons>> car ] keep
|
||||
quot>> call ;
|
||||
|
||||
M: lazy-map cdr ( lazy-map -- cdr )
|
||||
[ cons>> cdr ] keep
|
||||
quot>> lazy-map ;
|
||||
|
||||
M: lazy-map nil? ( lazy-map -- bool )
|
||||
cons>> nil? ;
|
||||
|
||||
: lazy-map-with ( value list quot -- result )
|
||||
with lazy-map ;
|
||||
|
||||
TUPLE: lazy-take n cons ;
|
||||
|
||||
C: <lazy-take> lazy-take
|
||||
|
||||
: ltake ( n list -- result )
|
||||
over zero? [ 2drop nil ] [ <lazy-take> ] if ;
|
||||
|
||||
M: lazy-take car ( lazy-take -- car )
|
||||
cons>> car ;
|
||||
|
||||
M: lazy-take cdr ( lazy-take -- cdr )
|
||||
[ n>> 1- ] keep
|
||||
cons>> cdr ltake ;
|
||||
|
||||
M: lazy-take nil? ( lazy-take -- bool )
|
||||
dup n>> zero? [
|
||||
drop t
|
||||
] [
|
||||
cons>> nil?
|
||||
] if ;
|
||||
|
||||
TUPLE: lazy-until cons quot ;
|
||||
|
||||
C: <lazy-until> lazy-until
|
||||
|
||||
: luntil ( list quot -- result )
|
||||
over nil? [ drop ] [ <lazy-until> ] if ;
|
||||
|
||||
M: lazy-until car ( lazy-until -- car )
|
||||
cons>> car ;
|
||||
|
||||
M: lazy-until cdr ( lazy-until -- cdr )
|
||||
[ cons>> uncons ] keep quot>> tuck call
|
||||
[ 2drop nil ] [ luntil ] if ;
|
||||
|
||||
M: lazy-until nil? ( lazy-until -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-while cons quot ;
|
||||
|
||||
C: <lazy-while> lazy-while
|
||||
|
||||
: lwhile ( list quot -- result )
|
||||
over nil? [ drop ] [ <lazy-while> ] if ;
|
||||
|
||||
M: lazy-while car ( lazy-while -- car )
|
||||
cons>> car ;
|
||||
|
||||
M: lazy-while cdr ( lazy-while -- cdr )
|
||||
[ cons>> cdr ] keep quot>> lwhile ;
|
||||
|
||||
M: lazy-while nil? ( lazy-while -- bool )
|
||||
[ car ] keep quot>> call not ;
|
||||
|
||||
TUPLE: lazy-filter cons quot ;
|
||||
|
||||
C: <lazy-filter> lazy-filter
|
||||
|
||||
: lfilter ( list quot -- result )
|
||||
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
|
||||
|
||||
: car-filter? ( lazy-filter -- ? )
|
||||
[ cons>> car ] [ quot>> ] bi call ;
|
||||
|
||||
: skip ( lazy-filter -- )
|
||||
dup cons>> cdr >>cons drop ;
|
||||
|
||||
M: lazy-filter car ( lazy-filter -- car )
|
||||
dup car-filter? [ cons>> ] [ dup skip ] if car ;
|
||||
|
||||
M: lazy-filter cdr ( lazy-filter -- cdr )
|
||||
dup car-filter? [
|
||||
[ cons>> cdr ] [ quot>> ] bi lfilter
|
||||
] [
|
||||
dup skip cdr
|
||||
] if ;
|
||||
|
||||
M: lazy-filter nil? ( lazy-filter -- bool )
|
||||
dup cons>> nil? [
|
||||
drop t
|
||||
] [
|
||||
dup car-filter? [
|
||||
drop f
|
||||
] [
|
||||
dup skip nil?
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: list>vector ( list -- vector )
|
||||
[ [ , ] leach ] V{ } make ;
|
||||
|
||||
: list>array ( list -- array )
|
||||
[ [ , ] leach ] { } make ;
|
||||
|
||||
TUPLE: lazy-append list1 list2 ;
|
||||
|
||||
C: <lazy-append> lazy-append
|
||||
|
||||
: lappend ( list1 list2 -- result )
|
||||
over nil? [ nip ] [ <lazy-append> ] if ;
|
||||
|
||||
M: lazy-append car ( lazy-append -- car )
|
||||
list1>> car ;
|
||||
|
||||
M: lazy-append cdr ( lazy-append -- cdr )
|
||||
[ list1>> cdr ] keep
|
||||
list2>> lappend ;
|
||||
|
||||
M: lazy-append nil? ( lazy-append -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-from-by n quot ;
|
||||
|
||||
C: lfrom-by lazy-from-by ( n quot -- list )
|
||||
|
||||
: lfrom ( n -- list )
|
||||
[ 1+ ] lfrom-by ;
|
||||
|
||||
M: lazy-from-by car ( lazy-from-by -- car )
|
||||
n>> ;
|
||||
|
||||
M: lazy-from-by cdr ( lazy-from-by -- cdr )
|
||||
[ n>> ] keep
|
||||
quot>> dup slip lfrom-by ;
|
||||
|
||||
M: lazy-from-by nil? ( lazy-from-by -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-zip list1 list2 ;
|
||||
|
||||
C: <lazy-zip> lazy-zip
|
||||
|
||||
: lzip ( list1 list2 -- lazy-zip )
|
||||
over nil? over nil? or
|
||||
[ 2drop nil ] [ <lazy-zip> ] if ;
|
||||
|
||||
M: lazy-zip car ( lazy-zip -- car )
|
||||
[ list1>> car ] keep list2>> car 2array ;
|
||||
|
||||
M: lazy-zip cdr ( lazy-zip -- cdr )
|
||||
[ list1>> cdr ] keep list2>> cdr lzip ;
|
||||
|
||||
M: lazy-zip nil? ( lazy-zip -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: sequence-cons index seq ;
|
||||
|
||||
C: <sequence-cons> sequence-cons
|
||||
|
||||
: seq>list ( index seq -- list )
|
||||
2dup length >= [
|
||||
2drop nil
|
||||
] [
|
||||
<sequence-cons>
|
||||
] if ;
|
||||
|
||||
M: sequence-cons car ( sequence-cons -- car )
|
||||
[ index>> ] keep
|
||||
seq>> nth ;
|
||||
|
||||
M: sequence-cons cdr ( sequence-cons -- cdr )
|
||||
[ index>> 1+ ] keep
|
||||
seq>> seq>list ;
|
||||
|
||||
M: sequence-cons nil? ( sequence-cons -- bool )
|
||||
drop f ;
|
||||
|
||||
: >list ( object -- list )
|
||||
{
|
||||
{ [ dup sequence? ] [ 0 swap seq>list ] }
|
||||
{ [ dup list? ] [ ] }
|
||||
[ "Could not convert object to a list" throw ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: lazy-concat car cdr ;
|
||||
|
||||
C: <lazy-concat> lazy-concat
|
||||
|
||||
DEFER: lconcat
|
||||
|
||||
: (lconcat) ( car cdr -- list )
|
||||
over nil? [
|
||||
nip lconcat
|
||||
] [
|
||||
<lazy-concat>
|
||||
] if ;
|
||||
|
||||
: lconcat ( list -- result )
|
||||
dup nil? [
|
||||
drop nil
|
||||
] [
|
||||
uncons swap (lconcat)
|
||||
] if ;
|
||||
|
||||
M: lazy-concat car ( lazy-concat -- car )
|
||||
car>> car ;
|
||||
|
||||
M: lazy-concat cdr ( lazy-concat -- cdr )
|
||||
[ car>> cdr ] keep cdr>> (lconcat) ;
|
||||
|
||||
M: lazy-concat nil? ( lazy-concat -- bool )
|
||||
dup car>> nil? [
|
||||
cdr>> nil?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: lcartesian-product ( list1 list2 -- result )
|
||||
swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ;
|
||||
|
||||
: lcartesian-product* ( lists -- result )
|
||||
dup nil? [
|
||||
drop nil
|
||||
] [
|
||||
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
|
||||
swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat
|
||||
] reduce
|
||||
] if ;
|
||||
|
||||
: lcomp ( list quot -- result )
|
||||
[ lcartesian-product* ] dip lazy-map ;
|
||||
|
||||
: lcomp* ( list guards quot -- result )
|
||||
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
|
||||
|
||||
DEFER: lmerge
|
||||
|
||||
: (lmerge) ( list1 list2 -- result )
|
||||
over [ car ] curry -rot
|
||||
[
|
||||
dup [ car ] curry -rot
|
||||
[
|
||||
[ cdr ] bi@ lmerge
|
||||
] 2curry lazy-cons
|
||||
] 2curry lazy-cons ;
|
||||
|
||||
: lmerge ( list1 list2 -- result )
|
||||
{
|
||||
{ [ over nil? ] [ nip ] }
|
||||
{ [ dup nil? ] [ drop ] }
|
||||
{ [ t ] [ (lmerge) ] }
|
||||
} cond ;
|
||||
|
||||
TUPLE: lazy-io stream car cdr quot ;
|
||||
|
||||
C: <lazy-io> lazy-io
|
||||
|
||||
: lcontents ( stream -- result )
|
||||
f f [ stream-read1 ] <lazy-io> ;
|
||||
|
||||
: llines ( stream -- result )
|
||||
f f [ stream-readln ] <lazy-io> ;
|
||||
|
||||
M: lazy-io car ( lazy-io -- car )
|
||||
dup car>> dup [
|
||||
nip
|
||||
] [
|
||||
drop dup stream>> over quot>> call
|
||||
swap dupd set-lazy-io-car
|
||||
] if ;
|
||||
|
||||
M: lazy-io cdr ( lazy-io -- cdr )
|
||||
dup cdr>> dup [
|
||||
nip
|
||||
] [
|
||||
drop dup
|
||||
[ stream>> ] keep
|
||||
[ quot>> ] keep
|
||||
car [
|
||||
[ f f ] dip <lazy-io> [ >>cdr drop ] keep
|
||||
] [
|
||||
3drop nil
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: lazy-io nil? ( lazy-io -- bool )
|
||||
car not ;
|
||||
|
||||
INSTANCE: sequence-cons list
|
||||
INSTANCE: memoized-cons list
|
||||
INSTANCE: promise list
|
||||
INSTANCE: lazy-io list
|
||||
INSTANCE: lazy-concat list
|
||||
INSTANCE: lazy-cons list
|
||||
INSTANCE: lazy-map list
|
||||
INSTANCE: lazy-take list
|
||||
INSTANCE: lazy-append list
|
||||
INSTANCE: lazy-from-by list
|
||||
INSTANCE: lazy-zip list
|
||||
INSTANCE: lazy-while list
|
||||
INSTANCE: lazy-until list
|
||||
INSTANCE: lazy-filter list
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
IN: lists
|
||||
|
||||
{ car cons cdr nil nil? list? uncons } related-words
|
||||
|
||||
HELP: cons
|
||||
{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
|
||||
{ $description "Constructs a cons cell." } ;
|
||||
|
||||
HELP: car
|
||||
{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
|
||||
{ $description "Returns the first item in the list." } ;
|
||||
|
||||
HELP: cdr
|
||||
{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
|
||||
{ $description "Returns the tail of the list." } ;
|
||||
|
||||
HELP: nil
|
||||
{ $values { "symbol" "The empty cons (+nil+)" } }
|
||||
{ $description "Returns a symbol representing the empty list" } ;
|
||||
|
||||
HELP: nil?
|
||||
{ $values { "cons" "a cons object" } { "?" "a boolean" } }
|
||||
{ $description "Return true if the cons object is the nil cons." } ;
|
||||
|
||||
HELP: list? ( object -- ? )
|
||||
{ $values { "object" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Returns true if the object conforms to the list protocol." } ;
|
||||
|
||||
{ 1list 2list 3list } related-words
|
||||
|
||||
HELP: 1list
|
||||
{ $values { "obj" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 1 element." } ;
|
||||
|
||||
HELP: 2list
|
||||
{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 2 elements." } ;
|
||||
|
||||
HELP: 3list
|
||||
{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 3 elements." } ;
|
||||
|
||||
HELP: lnth
|
||||
{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
|
||||
{ $description "Outputs the nth element of the list." }
|
||||
{ $see-also llength cons car cdr } ;
|
||||
|
||||
HELP: llength
|
||||
{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
|
||||
{ $description "Outputs the length of the list. This should not be called on an infinite list." }
|
||||
{ $see-also lnth cons car cdr } ;
|
||||
|
||||
HELP: uncons
|
||||
{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } }
|
||||
{ $description "Put the head and tail of the list on the stack." } ;
|
||||
|
||||
{ leach foldl lmap>array } related-words
|
||||
|
||||
HELP: leach
|
||||
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
|
||||
{ $description "Call the quotation for each item in the list." } ;
|
||||
|
||||
HELP: foldl
|
||||
{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
|
||||
{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
|
||||
|
||||
HELP: foldr
|
||||
{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
|
||||
{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
|
||||
|
||||
HELP: lmap
|
||||
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } }
|
||||
{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
|
||||
|
||||
HELP: lreverse
|
||||
{ $values { "list" "a cons object" } { "newlist" "a new cons object" } }
|
||||
{ $description "Reverses the input list, outputing a new, reversed list" } ;
|
||||
|
||||
HELP: list>seq
|
||||
{ $values { "list" "a cons object" } { "array" "an array object" } }
|
||||
{ $description "Turns the given cons object into an array, maintaing order." } ;
|
||||
|
||||
HELP: seq>list
|
||||
{ $values { "seq" "a sequence" } { "list" "a cons object" } }
|
||||
{ $description "Turns the given array into a cons object, maintaing order." } ;
|
||||
|
||||
HELP: cons>seq
|
||||
{ $values { "cons" "a cons object" } { "array" "an array object" } }
|
||||
{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ;
|
||||
|
||||
HELP: seq>cons
|
||||
{ $values { "seq" "a sequence object" } { "cons" "a cons object" } }
|
||||
{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
|
||||
|
||||
HELP: traverse
|
||||
{ $values { "list" "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" }
|
||||
{ "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } }
|
||||
{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred"
|
||||
" returns true for with the result of applying quot to." } ;
|
||||
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test lists math ;
|
||||
|
||||
IN: lists.tests
|
||||
|
||||
{ { 3 4 5 6 7 } } [
|
||||
{ 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq
|
||||
] unit-test
|
||||
|
||||
{ { 3 4 5 6 } } [
|
||||
T{ cons f 1
|
||||
T{ cons f 2
|
||||
T{ cons f 3
|
||||
T{ cons f 4
|
||||
+nil+ } } } } [ 2 + ] lmap>array
|
||||
] unit-test
|
||||
|
||||
{ 10 } [
|
||||
T{ cons f 1
|
||||
T{ cons f 2
|
||||
T{ cons f 3
|
||||
T{ cons f 4
|
||||
+nil+ } } } } 0 [ + ] foldl
|
||||
] unit-test
|
||||
|
||||
{ T{ cons f
|
||||
1
|
||||
T{ cons f
|
||||
2
|
||||
T{ cons f
|
||||
T{ cons f
|
||||
3
|
||||
T{ cons f
|
||||
4
|
||||
T{ cons f
|
||||
T{ cons f 5 +nil+ }
|
||||
+nil+ } } }
|
||||
+nil+ } } }
|
||||
} [
|
||||
{ 1 2 { 3 4 { 5 } } } seq>cons
|
||||
] unit-test
|
||||
|
||||
{ { 1 2 { 3 4 { 5 } } } } [
|
||||
{ 1 2 { 3 4 { 5 } } } seq>cons cons>seq
|
||||
] unit-test
|
||||
|
||||
{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
|
||||
{ 1 2 3 4 } seq>cons [ 1+ ] lmap
|
||||
] unit-test
|
||||
|
||||
{ 15 } [
|
||||
{ 1 2 3 4 5 } seq>list 0 [ + ] foldr
|
||||
] unit-test
|
||||
|
||||
{ { 5 4 3 2 1 } } [
|
||||
{ 1 2 3 4 5 } seq>list lreverse list>seq
|
||||
] unit-test
|
||||
|
||||
{ 5 } [
|
||||
{ 1 2 3 4 5 } seq>list llength
|
||||
] unit-test
|
||||
|
||||
{ { 3 4 { 5 6 { 7 } } } } [
|
||||
{ 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
! Copyright (C) 2008 Chris Double & James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors math arrays vectors classes words locals ;
|
||||
|
||||
IN: lists
|
||||
|
||||
! List Protocol
|
||||
MIXIN: list
|
||||
GENERIC: car ( cons -- car )
|
||||
GENERIC: cdr ( cons -- cdr )
|
||||
GENERIC: nil? ( object -- ? )
|
||||
|
||||
TUPLE: cons car cdr ;
|
||||
|
||||
C: cons cons
|
||||
|
||||
M: cons car ( cons -- car )
|
||||
car>> ;
|
||||
|
||||
M: cons cdr ( cons -- cdr )
|
||||
cdr>> ;
|
||||
|
||||
SYMBOL: +nil+
|
||||
M: word nil? +nil+ eq? ;
|
||||
M: object nil? drop f ;
|
||||
|
||||
: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
|
||||
|
||||
: nil ( -- symbol ) +nil+ ;
|
||||
|
||||
: uncons ( cons -- cdr car )
|
||||
[ cdr ] [ car ] bi ;
|
||||
|
||||
: 1list ( obj -- cons )
|
||||
nil cons ;
|
||||
|
||||
: 2list ( a b -- cons )
|
||||
nil cons cons ;
|
||||
|
||||
: 3list ( a b c -- cons )
|
||||
nil cons cons cons ;
|
||||
|
||||
: cadr ( cons -- elt )
|
||||
cdr car ;
|
||||
|
||||
: 2car ( cons -- car caar )
|
||||
[ car ] [ cdr car ] bi ;
|
||||
|
||||
: 3car ( cons -- car caar caaar )
|
||||
[ car ] [ cdr car ] [ cdr cdr car ] tri ;
|
||||
|
||||
: lnth ( n list -- elt )
|
||||
swap [ cdr ] times car ;
|
||||
|
||||
: (leach) ( list quot -- cdr quot )
|
||||
[ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
|
||||
|
||||
: leach ( list quot -- )
|
||||
over nil? [ 2drop ] [ (leach) leach ] if ; inline
|
||||
|
||||
: lmap ( list quot -- result )
|
||||
over nil? [ drop ] [ (leach) lmap cons ] if ; inline
|
||||
|
||||
: foldl ( list identity quot -- result ) swapd leach ; inline
|
||||
|
||||
: foldr ( list identity quot -- result )
|
||||
pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
|
||||
[ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
|
||||
call
|
||||
] if ; inline
|
||||
|
||||
: llength ( list -- n )
|
||||
0 [ drop 1+ ] foldl ;
|
||||
|
||||
: lreverse ( list -- newlist )
|
||||
nil [ swap cons ] foldl ;
|
||||
|
||||
: seq>list ( seq -- list )
|
||||
<reversed> nil [ swap cons ] reduce ;
|
||||
|
||||
: same? ( obj1 obj2 -- ? )
|
||||
[ class ] bi@ = ;
|
||||
|
||||
: seq>cons ( seq -- cons )
|
||||
[ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
|
||||
|
||||
: (lmap>array) ( acc cons quot -- newcons )
|
||||
over nil? [ 2drop ]
|
||||
[ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline
|
||||
|
||||
: lmap>array ( cons quot -- newcons )
|
||||
{ } -rot (lmap>array) ; inline
|
||||
|
||||
: lmap-as ( cons quot exemplar -- seq )
|
||||
[ lmap>array ] dip like ;
|
||||
|
||||
: cons>seq ( cons -- array )
|
||||
[ dup cons? [ cons>seq ] when ] lmap>array ;
|
||||
|
||||
: list>seq ( list -- array )
|
||||
[ ] lmap>array ;
|
||||
|
||||
: traverse ( list pred quot -- result )
|
||||
[ 2over call [ tuck [ call ] 2dip ] when
|
||||
pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ;
|
||||
|
||||
INSTANCE: cons list
|
||||
|
|
@ -0,0 +1 @@
|
|||
Implementation of lisp-style linked lists
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
cons
|
||||
lists
|
||||
sequences
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists math.erato tools.test ;
|
||||
USING: lists.lazy math.erato tools.test ;
|
||||
IN: math.erato.tests
|
||||
|
||||
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bit-arrays kernel lazy-lists math math.functions math.primes.list
|
||||
USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
|
||||
math.ranges sequences ;
|
||||
IN: math.erato
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel lazy-lists math math.primes namespaces sequences ;
|
||||
USING: arrays kernel lists math math.primes namespaces sequences ;
|
||||
IN: math.primes.factors
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -17,7 +17,7 @@ IN: math.primes.factors
|
|||
dup empty? [ drop ] [ first , ] if ;
|
||||
|
||||
: (factors) ( quot list n -- )
|
||||
dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
|
||||
dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
|
||||
|
||||
: (decompose) ( n quot -- seq )
|
||||
[ lprimes rot (factors) ] { } make ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: arrays math.primes tools.test lazy-lists ;
|
||||
USING: arrays math.primes tools.test lists.lazy ;
|
||||
|
||||
{ 1237 } [ 1234 next-prime ] unit-test
|
||||
{ f t } [ 1234 prime? 1237 prime? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel lazy-lists math math.functions math.miller-rabin
|
||||
USING: combinators kernel lists.lazy math math.functions math.miller-rabin
|
||||
math.order math.primes.list math.ranges sequences sorting ;
|
||||
IN: math.primes
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.test monads math kernel sequences lazy-lists promises ;
|
||||
USING: tools.test monads math kernel sequences lists promises ;
|
||||
IN: monads.tests
|
||||
|
||||
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel sequences sequences.deep splitting
|
||||
accessors fry locals combinators namespaces lazy-lists
|
||||
accessors fry locals combinators namespaces lists lists.lazy
|
||||
shuffle ;
|
||||
IN: monads
|
||||
|
||||
|
|
@ -124,7 +124,7 @@ M: list-monad fail 2drop nil ;
|
|||
|
||||
M: list monad-of drop list-monad ;
|
||||
|
||||
M: list >>= '[ , _ lmap lconcat ] ;
|
||||
M: list >>= '[ , _ lazy-map lconcat ] ;
|
||||
|
||||
! State
|
||||
SINGLETON: state-monad
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
|
||||
USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
|
||||
IN: morse
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays kernel debugger sequences namespaces math
|
||||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors debugger inspector
|
||||
continuations destructors debugger inspector splitting
|
||||
locals unicode.case
|
||||
openssl.libcrypto openssl.libssl
|
||||
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
|
||||
|
|
@ -188,8 +188,12 @@ M: ssl-handle dispose*
|
|||
[ 256 X509_NAME_get_text_by_NID ] keep
|
||||
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
|
||||
|
||||
: common-names-match? ( expected actual -- ? )
|
||||
[ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
|
||||
|
||||
: check-common-name ( host ssl-handle -- )
|
||||
SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
|
||||
SSL_get_peer_certificate common-name
|
||||
2dup common-names-match?
|
||||
[ 2drop ] [ common-name-verify-error ] if ;
|
||||
|
||||
M: openssl check-certificate ( host ssl -- )
|
||||
|
|
|
|||
|
|
@ -23,4 +23,4 @@ HELP: any-char-parser
|
|||
"from the input string. The value consumed is the "
|
||||
"result of the parse." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel lazy-lists tools.test strings math
|
||||
USING: kernel lists.lazy tools.test strings math
|
||||
sequences parser-combinators arrays math.parser unicode.categories ;
|
||||
IN: parser-combinators.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists promises kernel sequences strings math
|
||||
USING: lists lists.lazy promises kernel sequences strings math
|
||||
arrays splitting quotations combinators namespaces
|
||||
unicode.case unicode.categories sequences.deep ;
|
||||
IN: parser-combinators
|
||||
|
|
@ -147,8 +147,8 @@ TUPLE: and-parser parsers ;
|
|||
>r parse-result-parsed r>
|
||||
[ parse-result-parsed 2array ] keep
|
||||
parse-result-unparsed <parse-result>
|
||||
] lmap-with
|
||||
] lmap-with lconcat ;
|
||||
] lazy-map-with
|
||||
] lazy-map-with lconcat ;
|
||||
|
||||
M: and-parser parse ( input parser -- list )
|
||||
#! Parse 'input' by sequentially combining the
|
||||
|
|
@ -171,7 +171,7 @@ M: or-parser parse ( input parser1 -- list )
|
|||
#! of parser1 and parser2 being applied to the same
|
||||
#! input. This implements the choice parsing operator.
|
||||
or-parser-parsers 0 swap seq>list
|
||||
[ parse ] lmap-with lconcat ;
|
||||
[ parse ] lazy-map-with lconcat ;
|
||||
|
||||
: left-trim-slice ( string -- string )
|
||||
#! Return a new string without any leading whitespace
|
||||
|
|
@ -216,7 +216,7 @@ M: apply-parser parse ( input parser -- result )
|
|||
-rot parse [
|
||||
[ parse-result-parsed swap call ] keep
|
||||
parse-result-unparsed <parse-result>
|
||||
] lmap-with ;
|
||||
] lazy-map-with ;
|
||||
|
||||
TUPLE: some-parser p1 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ HELP: 'digit'
|
|||
"the input string. The numeric value of the digit "
|
||||
" consumed is the result of the parse." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
|
||||
|
||||
HELP: 'integer'
|
||||
{ $values
|
||||
|
|
@ -21,7 +21,7 @@ HELP: 'integer'
|
|||
"the input string. The numeric value of the integer "
|
||||
" consumed is the result of the parse." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
|
||||
HELP: 'string'
|
||||
{ $values
|
||||
{ "parser" "a parser object" } }
|
||||
|
|
@ -30,7 +30,7 @@ HELP: 'string'
|
|||
"quotations from the input string. The string value "
|
||||
" consumed is the result of the parse." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
|
||||
|
||||
HELP: 'bold'
|
||||
{ $values
|
||||
|
|
@ -62,6 +62,6 @@ HELP: comma-list
|
|||
"'element' should be a parser that can parse the elements. The "
|
||||
"result of the parser is a sequence of the parsed elements." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
|
||||
|
||||
{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel strings math sequences lazy-lists words
|
||||
USING: kernel strings math sequences lists.lazy words
|
||||
math.parser promises parser-combinators unicode.categories ;
|
||||
IN: parser-combinators.simple
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
USING: help.markup help.syntax kernel math sequences ;
|
||||
IN: persistent-vectors
|
||||
|
||||
HELP: new-nth
|
||||
{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
|
||||
{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
|
||||
{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
|
||||
|
||||
HELP: ppush
|
||||
{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
|
||||
{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
|
||||
{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
|
||||
|
||||
HELP: ppop
|
||||
{ $values { "seq" sequence } { "seq'" sequence } }
|
||||
{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
|
||||
{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
|
||||
|
||||
HELP: PV{
|
||||
{ $syntax "elements... }" }
|
||||
{ $description "Parses a literal " { $link persistent-vector } "." } ;
|
||||
|
||||
HELP: >persistent-vector
|
||||
{ $values { "seq" sequence } { "pvec" persistent-vector } }
|
||||
{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ;
|
||||
|
||||
HELP: persistent-vector
|
||||
{ $class-description "The class of persistent vectors." } ;
|
||||
|
||||
HELP: pempty
|
||||
{ $values { "pvec" persistent-vector } }
|
||||
{ $description "Outputs an empty " { $link persistent-vector } "." } ;
|
||||
|
||||
ARTICLE: "persistent-vectors" "Persistent vectors"
|
||||
"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
|
||||
$nl
|
||||
"The class of persistent vectors:"
|
||||
{ $subsection persistent-vector }
|
||||
"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
|
||||
$nl
|
||||
"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
|
||||
{ $subsection new-nth }
|
||||
{ $subsection ppush }
|
||||
{ $subsection ppop }
|
||||
"The empty persistent vector, used for building up all other persistent vectors:"
|
||||
{ $subsection pempty }
|
||||
"Converting a sequence into a persistent vector:"
|
||||
{ $subsection >persistent-vector }
|
||||
"Persistent vectors have a literal syntax:"
|
||||
{ $subsection POSTPONE: PV{ }
|
||||
"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
|
||||
|
||||
ABOUT: "persistent-vectors"
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
IN: persistent-vectors.tests
|
||||
USING: tools.test persistent-vectors sequences kernel arrays
|
||||
random namespaces vectors math math.order ;
|
||||
|
||||
\ new-nth must-infer
|
||||
\ ppush must-infer
|
||||
\ ppop must-infer
|
||||
|
||||
[ 0 ] [ pempty length ] unit-test
|
||||
|
||||
[ 1 ] [ 3 pempty ppush length ] unit-test
|
||||
|
||||
[ 3 ] [ 3 pempty ppush first ] unit-test
|
||||
|
||||
[ PV{ 3 1 3 3 7 } ] [
|
||||
pempty { 3 1 3 3 7 } [ swap ppush ] each
|
||||
] unit-test
|
||||
|
||||
[ { 3 1 3 3 7 } ] [
|
||||
pempty { 3 1 3 3 7 } [ swap ppush ] each >array
|
||||
] unit-test
|
||||
|
||||
{ 100 1060 2000 10000 100000 1000000 } [
|
||||
[ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
|
||||
] each
|
||||
|
||||
[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test
|
||||
[ ] [ "1" get >vector "2" set ] unit-test
|
||||
|
||||
[ t ] [
|
||||
3000 [
|
||||
drop
|
||||
16 random-bits 10000 random
|
||||
[ "1" [ new-nth ] change ]
|
||||
[ "2" [ new-nth ] change ] 2bi
|
||||
"1" get "2" get sequence=
|
||||
] all?
|
||||
] unit-test
|
||||
|
||||
[ PV{ } ppop ] [ empty-error? ] must-fail-with
|
||||
|
||||
[ t ] [ PV{ 3 } ppop empty? ] unit-test
|
||||
|
||||
[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test
|
||||
|
||||
[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test
|
||||
|
||||
[ ] [ PV{ } "1" set ] unit-test
|
||||
[ ] [ V{ } clone "2" set ] unit-test
|
||||
|
||||
[ t ] [
|
||||
100 [
|
||||
drop
|
||||
100 random [
|
||||
16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi
|
||||
] times
|
||||
100 random "1" get length min [
|
||||
"1" [ ppop ] change
|
||||
"2" get pop*
|
||||
] times
|
||||
"1" get "2" get sequence=
|
||||
] all?
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,183 @@
|
|||
! Based on Clojure's PersistentVector by Rich Hickey.
|
||||
|
||||
USING: math accessors kernel sequences.private sequences arrays
|
||||
combinators parser prettyprint.backend ;
|
||||
IN: persistent-vectors
|
||||
|
||||
ERROR: empty-error pvec ;
|
||||
|
||||
GENERIC: ppush ( val seq -- seq' )
|
||||
|
||||
M: sequence ppush swap suffix ;
|
||||
|
||||
GENERIC: ppop ( seq -- seq' )
|
||||
|
||||
M: sequence ppop 1 head* ;
|
||||
|
||||
GENERIC: new-nth ( val i seq -- seq' )
|
||||
|
||||
M: sequence new-nth clone [ set-nth ] keep ;
|
||||
|
||||
TUPLE: persistent-vector count root tail ;
|
||||
|
||||
M: persistent-vector length count>> ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: node children level ;
|
||||
|
||||
: node-size 32 ; inline
|
||||
|
||||
: node-mask node-size mod ; inline
|
||||
|
||||
: node-shift -5 * shift ; inline
|
||||
|
||||
: node-nth ( i node -- obj )
|
||||
[ node-mask ] [ children>> ] bi* nth ; inline
|
||||
|
||||
: body-nth ( i node -- i node' )
|
||||
dup level>> [
|
||||
dupd [ level>> node-shift ] keep node-nth
|
||||
] times ; inline
|
||||
|
||||
: tail-offset ( pvec -- n )
|
||||
[ count>> ] [ tail>> children>> length ] bi - ;
|
||||
|
||||
M: persistent-vector nth-unsafe
|
||||
2dup tail-offset >=
|
||||
[ tail>> ] [ root>> body-nth ] if
|
||||
node-nth ;
|
||||
|
||||
: node-add ( val node -- node' )
|
||||
clone [ ppush ] change-children ;
|
||||
|
||||
: ppush-tail ( val pvec -- pvec' )
|
||||
[ node-add ] change-tail ;
|
||||
|
||||
: full? ( node -- ? )
|
||||
children>> length node-size = ;
|
||||
|
||||
: 1node ( val level -- node )
|
||||
node new
|
||||
swap >>level
|
||||
swap 1array >>children ;
|
||||
|
||||
: 2node ( first second -- node )
|
||||
[ 2array ] [ drop level>> 1+ ] 2bi node boa ;
|
||||
|
||||
: new-child ( new-child node -- node' expansion/f )
|
||||
dup full? [ tuck level>> 1node ] [ node-add f ] if ;
|
||||
|
||||
: new-last ( val seq -- seq' )
|
||||
[ length 1- ] keep new-nth ;
|
||||
|
||||
: node-set-last ( child node -- node' )
|
||||
clone [ new-last ] change-children ;
|
||||
|
||||
: (ppush-new-tail) ( tail node -- node' expansion/f )
|
||||
dup level>> 1 = [
|
||||
new-child
|
||||
] [
|
||||
tuck children>> peek (ppush-new-tail)
|
||||
[ swap new-child ] [ swap node-set-last f ] ?if
|
||||
] if ;
|
||||
|
||||
: do-expansion ( pvec root expansion/f -- pvec )
|
||||
[ 2node ] when* >>root ;
|
||||
|
||||
: ppush-new-tail ( val pvec -- pvec' )
|
||||
[ ] [ tail>> ] [ root>> ] tri
|
||||
(ppush-new-tail) do-expansion
|
||||
swap 0 1node >>tail ;
|
||||
|
||||
M: persistent-vector ppush ( val pvec -- pvec' )
|
||||
clone
|
||||
dup tail>> full?
|
||||
[ ppush-new-tail ] [ ppush-tail ] if
|
||||
[ 1+ ] change-count ;
|
||||
|
||||
: node-set-nth ( val i node -- node' )
|
||||
clone [ new-nth ] change-children ;
|
||||
|
||||
: node-change-nth ( i node quot -- node' )
|
||||
[ clone ] dip [
|
||||
[ clone ] dip [ change-nth ] 2keep drop
|
||||
] curry change-children ; inline
|
||||
|
||||
: (new-nth) ( val i node -- node' )
|
||||
dup level>> 0 = [
|
||||
[ node-mask ] dip node-set-nth
|
||||
] [
|
||||
[ dupd level>> node-shift node-mask ] keep
|
||||
[ (new-nth) ] node-change-nth
|
||||
] if ;
|
||||
|
||||
M: persistent-vector new-nth ( obj i pvec -- pvec' )
|
||||
2dup count>> = [ nip ppush ] [
|
||||
clone
|
||||
2dup tail-offset >= [
|
||||
[ node-mask ] dip
|
||||
[ node-set-nth ] change-tail
|
||||
] [
|
||||
[ (new-nth) ] change-root
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: (ppop-contraction) ( node -- node' tail' )
|
||||
clone [ unclip-last swap ] change-children swap ;
|
||||
|
||||
: ppop-contraction ( node -- node' tail' )
|
||||
[ (ppop-contraction) ] [ level>> 1 = ] bi swap and ;
|
||||
|
||||
: (ppop-new-tail) ( root -- root' tail' )
|
||||
dup level>> 1 > [
|
||||
dup children>> peek (ppop-new-tail) over children>> empty?
|
||||
[ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if
|
||||
] [
|
||||
ppop-contraction
|
||||
] if ;
|
||||
|
||||
: ppop-tail ( pvec -- pvec' )
|
||||
[ clone [ ppop ] change-children ] change-tail ;
|
||||
|
||||
: ppop-new-tail ( pvec -- pvec' )
|
||||
dup root>> (ppop-new-tail)
|
||||
[
|
||||
dup [ level>> 1 > ] [ children>> length 1 = ] bi and
|
||||
[ children>> first ] when
|
||||
] dip
|
||||
[ >>root ] [ >>tail ] bi* ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: pempty ( -- pvec )
|
||||
T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline
|
||||
|
||||
M: persistent-vector ppop ( pvec -- pvec' )
|
||||
dup count>> {
|
||||
{ 0 [ empty-error ] }
|
||||
{ 1 [ drop pempty ] }
|
||||
[
|
||||
[
|
||||
clone
|
||||
dup tail>> children>> length 1 >
|
||||
[ ppop-tail ] [ ppop-new-tail ] if
|
||||
] dip 1- >>count
|
||||
]
|
||||
} case ;
|
||||
|
||||
M: persistent-vector like
|
||||
drop pempty [ swap ppush ] reduce ;
|
||||
|
||||
M: persistent-vector equal?
|
||||
over persistent-vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
: >persistent-vector ( seq -- pvec ) pempty like ; inline
|
||||
|
||||
: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
|
||||
|
||||
M: persistent-vector pprint-delims drop \ PV{ \ } ;
|
||||
|
||||
M: persistent-vector >pprint-sequence ;
|
||||
|
||||
INSTANCE: persistent-vector immutable-sequence
|
||||
|
|
@ -0,0 +1 @@
|
|||
Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop
|
||||
|
|
@ -0,0 +1 @@
|
|||
collections
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: math math.parser calendar calendar.format strings words
|
||||
kernel ;
|
||||
IN: present
|
||||
|
||||
GENERIC: present ( object -- string )
|
||||
|
||||
M: real present number>string ;
|
||||
|
||||
M: timestamp present timestamp>string ;
|
||||
|
||||
M: string present ;
|
||||
|
||||
M: word present word-name ;
|
||||
|
||||
M: f present drop "" ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists math math.primes ;
|
||||
USING: lists math math.primes ;
|
||||
IN: project-euler.007
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=7
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel lazy-lists math.algebra math math.functions
|
||||
USING: arrays kernel lists lists.lazy math.algebra math math.functions
|
||||
math.order math.primes math.ranges project-euler.common sequences ;
|
||||
IN: project-euler.134
|
||||
|
||||
|
|
@ -39,7 +39,7 @@ IN: project-euler.134
|
|||
PRIVATE>
|
||||
|
||||
: euler134 ( -- answer )
|
||||
0 5 lprimes-from uncons [ 1000000 > ] luntil
|
||||
0 5 lprimes-from uncons swap [ 1000000 > ] luntil
|
||||
[ [ s + ] keep ] leach drop ;
|
||||
|
||||
! [ euler134 ] 10 ave-time
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: arrays combinators kernel lazy-lists math math.parser
|
||||
USING: arrays combinators kernel lists math math.parser
|
||||
namespaces parser parser-combinators parser-combinators.simple
|
||||
promises quotations sequences combinators.lib strings math.order
|
||||
assocs prettyprint.backend memoize unicode.case unicode.categories ;
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml.utilities kernel assocs xml.generator math.order
|
||||
strings sequences xml.data xml.writer
|
||||
io.streams.string combinators xml xml.entities io.files io
|
||||
http.client namespaces xml.generator hashtables
|
||||
calendar.format accessors continuations urls ;
|
||||
IN: rss
|
||||
|
||||
: any-tag-named ( tag names -- tag-inside )
|
||||
f -rot [ tag-named nip dup ] with find 2drop ;
|
||||
|
||||
TUPLE: feed title link entries ;
|
||||
|
||||
C: <feed> feed
|
||||
|
||||
TUPLE: entry title link description pub-date ;
|
||||
|
||||
C: <entry> entry
|
||||
|
||||
: try-parsing-timestamp ( string -- timestamp )
|
||||
[ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
|
||||
|
||||
: rss1.0-entry ( tag -- entry )
|
||||
{
|
||||
[ "title" tag-named children>string ]
|
||||
[ "link" tag-named children>string ]
|
||||
[ "description" tag-named children>string ]
|
||||
[
|
||||
f "date" "http://purl.org/dc/elements/1.1/" <name>
|
||||
tag-named dup [ children>string try-parsing-timestamp ] when
|
||||
]
|
||||
} cleave <entry> ;
|
||||
|
||||
: rss1.0 ( xml -- feed )
|
||||
[
|
||||
"channel" tag-named
|
||||
[ "title" tag-named children>string ]
|
||||
[ "link" tag-named children>string ] bi
|
||||
] [ "item" tags-named [ rss1.0-entry ] map ] bi
|
||||
<feed> ;
|
||||
|
||||
: rss2.0-entry ( tag -- entry )
|
||||
{
|
||||
[ "title" tag-named children>string ]
|
||||
[ { "link" "guid" } any-tag-named children>string ]
|
||||
[ "description" tag-named children>string ]
|
||||
[
|
||||
{ "date" "pubDate" } any-tag-named
|
||||
children>string try-parsing-timestamp
|
||||
]
|
||||
} cleave <entry> ;
|
||||
|
||||
: rss2.0 ( xml -- feed )
|
||||
"channel" tag-named
|
||||
[ "title" tag-named children>string ]
|
||||
[ "link" tag-named children>string ]
|
||||
[ "item" tags-named [ rss2.0-entry ] map ]
|
||||
tri <feed> ;
|
||||
|
||||
: atom1.0-entry ( tag -- entry )
|
||||
{
|
||||
[ "title" tag-named children>string ]
|
||||
[ "link" tag-named "href" swap at ]
|
||||
[
|
||||
{ "content" "summary" } any-tag-named
|
||||
dup tag-children [ string? not ] contains?
|
||||
[ tag-children [ write-chunk ] with-string-writer ]
|
||||
[ children>string ] if
|
||||
]
|
||||
[
|
||||
{ "published" "updated" "issued" "modified" }
|
||||
any-tag-named children>string try-parsing-timestamp
|
||||
]
|
||||
} cleave <entry> ;
|
||||
|
||||
: atom1.0 ( xml -- feed )
|
||||
[ "title" tag-named children>string ]
|
||||
[ "link" tag-named "href" swap at ]
|
||||
[ "entry" tags-named [ atom1.0-entry ] map ]
|
||||
tri <feed> ;
|
||||
|
||||
: xml>feed ( xml -- feed )
|
||||
dup name-tag {
|
||||
{ "RDF" [ rss1.0 ] }
|
||||
{ "rss" [ rss2.0 ] }
|
||||
{ "feed" [ atom1.0 ] }
|
||||
} case ;
|
||||
|
||||
: read-feed ( string -- feed )
|
||||
[ string>xml xml>feed ] with-html-entities ;
|
||||
|
||||
: download-feed ( url -- feed )
|
||||
#! Retrieve an news syndication file, return as a feed tuple.
|
||||
http-get read-feed ;
|
||||
|
||||
! Atom generation
|
||||
: simple-tag, ( content name -- )
|
||||
[ , ] tag, ;
|
||||
|
||||
: simple-tag*, ( content name attrs -- )
|
||||
[ , ] tag*, ;
|
||||
|
||||
: entry, ( entry -- )
|
||||
"entry" [
|
||||
dup title>> "title" { { "type" "html" } } simple-tag*,
|
||||
"link" over link>> dup url? [ url>string ] when "href" associate contained*,
|
||||
dup pub-date>> timestamp>rfc3339 "published" simple-tag,
|
||||
description>> [ "content" { { "type" "html" } } simple-tag*, ] when*
|
||||
] tag, ;
|
||||
|
||||
: feed>xml ( feed -- xml )
|
||||
"feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
|
||||
dup title>> "title" simple-tag,
|
||||
"link" over link>> dup url? [ url>string ] when "href" associate contained*,
|
||||
entries>> [ entry, ] each
|
||||
] make-xml* ;
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
Daniel Ehrenberg
|
||||
Chris Double
|
||||
Slava Pestov
|
||||
|
|
@ -1,6 +1,9 @@
|
|||
USING: rss io kernel io.files tools.test io.encodings.utf8
|
||||
calendar ;
|
||||
IN: rss.tests
|
||||
USING: syndication io kernel io.files tools.test io.encodings.utf8
|
||||
calendar urls ;
|
||||
IN: syndication.tests
|
||||
|
||||
\ download-feed must-infer
|
||||
\ feed>xml must-infer
|
||||
|
||||
: load-news-file ( filename -- feed )
|
||||
#! Load an news syndication file and process it, returning
|
||||
|
|
@ -11,32 +14,32 @@ IN: rss.tests
|
|||
feed
|
||||
f
|
||||
"Meerkat"
|
||||
"http://meerkat.oreillynet.com"
|
||||
URL" http://meerkat.oreillynet.com"
|
||||
{
|
||||
T{
|
||||
entry
|
||||
f
|
||||
"XML: A Disruptive Technology"
|
||||
"http://c.moreover.com/click/here.pl?r123"
|
||||
URL" http://c.moreover.com/click/here.pl?r123"
|
||||
"\n XML is placing increasingly heavy loads on the existing technical\n infrastructure of the Internet.\n "
|
||||
f
|
||||
}
|
||||
}
|
||||
} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test
|
||||
} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test
|
||||
[ T{
|
||||
feed
|
||||
f
|
||||
"dive into mark"
|
||||
"http://example.org/"
|
||||
URL" http://example.org/"
|
||||
{
|
||||
T{
|
||||
entry
|
||||
f
|
||||
"Atom draft-07 snapshot"
|
||||
"http://example.org/2005/04/02/atom"
|
||||
URL" http://example.org/2005/04/02/atom"
|
||||
"\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
|
||||
|
||||
T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
|
||||
}
|
||||
}
|
||||
} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test
|
||||
} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test
|
||||
|
|
@ -0,0 +1,135 @@
|
|||
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
|
||||
! Portions copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml.utilities kernel assocs xml.generator math.order
|
||||
strings sequences xml.data xml.writer
|
||||
io.streams.string combinators xml xml.entities io.files io
|
||||
http.client namespaces xml.generator hashtables
|
||||
calendar.format accessors continuations urls present ;
|
||||
IN: syndication
|
||||
|
||||
: any-tag-named ( tag names -- tag-inside )
|
||||
f -rot [ tag-named nip dup ] with find 2drop ;
|
||||
|
||||
TUPLE: feed title url entries ;
|
||||
|
||||
: <feed> ( -- feed ) feed new ;
|
||||
|
||||
TUPLE: entry title url description date ;
|
||||
|
||||
: set-entries ( feed entries -- feed )
|
||||
[ dup url>> ] dip
|
||||
[ [ derive-url ] change-url ] with map
|
||||
>>entries ;
|
||||
|
||||
: <entry> ( -- entry ) entry new ;
|
||||
|
||||
: try-parsing-timestamp ( string -- timestamp )
|
||||
[ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
|
||||
|
||||
: rss1.0-entry ( tag -- entry )
|
||||
entry new
|
||||
swap {
|
||||
[ "title" tag-named children>string >>title ]
|
||||
[ "link" tag-named children>string >url >>url ]
|
||||
[ "description" tag-named children>string >>description ]
|
||||
[
|
||||
f "date" "http://purl.org/dc/elements/1.1/" <name>
|
||||
tag-named dup [ children>string try-parsing-timestamp ] when
|
||||
>>date
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
: rss1.0 ( xml -- feed )
|
||||
feed new
|
||||
swap [
|
||||
"channel" tag-named
|
||||
[ "title" tag-named children>string >>title ]
|
||||
[ "link" tag-named children>string >url >>url ] bi
|
||||
] [ "item" tags-named [ rss1.0-entry ] map set-entries ] bi ;
|
||||
|
||||
: rss2.0-entry ( tag -- entry )
|
||||
entry new
|
||||
swap {
|
||||
[ "title" tag-named children>string >>title ]
|
||||
[ { "link" "guid" } any-tag-named children>string >url >>url ]
|
||||
[ "description" tag-named children>string >>description ]
|
||||
[
|
||||
{ "date" "pubDate" } any-tag-named
|
||||
children>string try-parsing-timestamp >>date
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
: rss2.0 ( xml -- feed )
|
||||
feed new
|
||||
swap
|
||||
"channel" tag-named
|
||||
[ "title" tag-named children>string >>title ]
|
||||
[ "link" tag-named children>string >url >>url ]
|
||||
[ "item" tags-named [ rss2.0-entry ] map set-entries ]
|
||||
tri ;
|
||||
|
||||
: atom1.0-entry ( tag -- entry )
|
||||
entry new
|
||||
swap {
|
||||
[ "title" tag-named children>string >>title ]
|
||||
[ "link" tag-named "href" swap at >url >>url ]
|
||||
[
|
||||
{ "content" "summary" } any-tag-named
|
||||
dup tag-children [ string? not ] contains?
|
||||
[ tag-children [ write-chunk ] with-string-writer ]
|
||||
[ children>string ] if >>description
|
||||
]
|
||||
[
|
||||
{ "published" "updated" "issued" "modified" }
|
||||
any-tag-named children>string try-parsing-timestamp
|
||||
>>date
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
: atom1.0 ( xml -- feed )
|
||||
feed new
|
||||
swap
|
||||
[ "title" tag-named children>string >>title ]
|
||||
[ "link" tag-named "href" swap at >url >>url ]
|
||||
[ "entry" tags-named [ atom1.0-entry ] map set-entries ]
|
||||
tri ;
|
||||
|
||||
: xml>feed ( xml -- feed )
|
||||
dup name-tag {
|
||||
{ "RDF" [ rss1.0 ] }
|
||||
{ "rss" [ rss2.0 ] }
|
||||
{ "feed" [ atom1.0 ] }
|
||||
} case ;
|
||||
|
||||
: read-feed ( string -- feed )
|
||||
[ string>xml xml>feed ] with-html-entities ;
|
||||
|
||||
: download-feed ( url -- feed )
|
||||
#! Retrieve an news syndication file, return as a feed tuple.
|
||||
http-get read-feed ;
|
||||
|
||||
! Atom generation
|
||||
: simple-tag, ( content name -- )
|
||||
[ , ] tag, ;
|
||||
|
||||
: simple-tag*, ( content name attrs -- )
|
||||
[ , ] tag*, ;
|
||||
|
||||
: entry, ( entry -- )
|
||||
"entry" [
|
||||
{
|
||||
[ title>> "title" { { "type" "html" } } simple-tag*, ]
|
||||
[ url>> present "href" associate "link" swap contained*, ]
|
||||
[ date>> timestamp>rfc3339 "published" simple-tag, ]
|
||||
[ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ]
|
||||
} cleave
|
||||
] tag, ;
|
||||
|
||||
: feed>xml ( feed -- xml )
|
||||
"feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
|
||||
[ title>> "title" simple-tag, ]
|
||||
[ url>> present "href" associate "link" swap contained*, ]
|
||||
[ entries>> [ entry, ] each ]
|
||||
tri
|
||||
] make-xml* ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
web
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences math math.functions tetris.board
|
||||
tetris.piece tetris.tetromino lazy-lists combinators system ;
|
||||
tetris.piece tetris.tetromino lists combinators system ;
|
||||
IN: tetris.game
|
||||
|
||||
TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays tetris.tetromino math math.vectors
|
||||
sequences quotations lazy-lists ;
|
||||
sequences quotations lists.lazy ;
|
||||
IN: tetris.piece
|
||||
|
||||
#! A piece adds state to the tetromino that is the piece's delegate. The
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
IN: urls.tests
|
||||
USING: urls tools.test tuple-syntax arrays kernel assocs ;
|
||||
USING: urls urls.private tools.test
|
||||
tuple-syntax arrays kernel assocs
|
||||
present ;
|
||||
|
||||
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
|
||||
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
|
||||
|
|
@ -110,7 +112,7 @@ urls [
|
|||
] assoc-each
|
||||
|
||||
urls [
|
||||
swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
|
||||
swap [ 1array ] [ [ present ] curry ] bi* unit-test
|
||||
] assoc-each
|
||||
|
||||
[ "b" ] [ "a" "b" url-append-path ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: kernel unicode.categories combinators sequences splitting
|
|||
fry namespaces assocs arrays strings io.sockets
|
||||
io.sockets.secure io.encodings.string io.encodings.utf8
|
||||
math math.parser accessors mirrors parser
|
||||
prettyprint.backend hashtables ;
|
||||
prettyprint.backend hashtables present ;
|
||||
IN: urls
|
||||
|
||||
: url-quotable? ( ch -- ? )
|
||||
|
|
@ -14,19 +14,25 @@ IN: urls
|
|||
{ [ dup letter? ] [ t ] }
|
||||
{ [ dup LETTER? ] [ t ] }
|
||||
{ [ dup digit? ] [ t ] }
|
||||
{ [ dup "/_-.:" member? ] [ t ] }
|
||||
{ [ dup "/_-." member? ] [ t ] }
|
||||
[ f ]
|
||||
} cond nip ; foldable
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: push-utf8 ( ch -- )
|
||||
1string utf8 encode
|
||||
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: url-encode ( str -- str )
|
||||
[
|
||||
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
|
||||
] "" make ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: url-decode-hex ( index str -- )
|
||||
2dup length 2 - >= [
|
||||
2drop
|
||||
|
|
@ -51,9 +57,13 @@ IN: urls
|
|||
] if url-decode-iter
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: url-decode ( str -- str )
|
||||
[ 0 swap url-decode-iter ] "" make utf8 decode ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: add-query-param ( value key assoc -- )
|
||||
[
|
||||
at [
|
||||
|
|
@ -65,6 +75,8 @@ IN: urls
|
|||
] when*
|
||||
] 2keep set-at ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: query>assoc ( query -- assoc )
|
||||
dup [
|
||||
"&" split H{ } clone [
|
||||
|
|
@ -77,11 +89,7 @@ IN: urls
|
|||
|
||||
: assoc>query ( hash -- str )
|
||||
[
|
||||
{
|
||||
{ [ dup number? ] [ number>string 1array ] }
|
||||
{ [ dup string? ] [ 1array ] }
|
||||
{ [ dup sequence? ] [ ] }
|
||||
} cond
|
||||
dup array? [ [ present ] map ] [ present 1array ] if
|
||||
] assoc-map
|
||||
[
|
||||
[
|
||||
|
|
@ -108,6 +116,8 @@ TUPLE: url protocol username password host port path query anchor ;
|
|||
] when
|
||||
] bi* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: parse-host-part ( url protocol rest -- url string' )
|
||||
[ >>protocol ] [
|
||||
"//" ?head [ "Invalid URL" throw ] unless
|
||||
|
|
@ -121,6 +131,8 @@ TUPLE: url protocol username password host port path query anchor ;
|
|||
] [ "/" prepend ] bi*
|
||||
] bi* ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: >url ( obj -- url )
|
||||
|
||||
M: url >url ;
|
||||
|
|
@ -135,6 +147,8 @@ M: string >url
|
|||
]
|
||||
[ url-decode >>anchor ] bi* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: unparse-username-password ( url -- )
|
||||
dup username>> dup [
|
||||
% password>> [ ":" % % ] when* "@" %
|
||||
|
|
@ -150,7 +164,7 @@ M: string >url
|
|||
[ path>> "/" head? [ "/" % ] unless ]
|
||||
} cleave ;
|
||||
|
||||
: url>string ( url -- string )
|
||||
M: url present
|
||||
[
|
||||
{
|
||||
[ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
|
||||
|
|
@ -169,6 +183,8 @@ M: string >url
|
|||
[ [ "/" last-split1 drop "/" ] dip 3append ]
|
||||
} cond ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: derive-url ( base url -- url' )
|
||||
[ clone dup ] dip
|
||||
2dup [ path>> ] bi@ url-append-path
|
||||
|
|
@ -199,4 +215,4 @@ M: string >url
|
|||
! Literal syntax
|
||||
: URL" lexer get skip-blank parse-string >url parsed ; parsing
|
||||
|
||||
M: url pprint* dup url>string "URL\" " "\"" pprint-string ;
|
||||
M: url pprint* dup present "URL\" " "\"" pprint-string ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ namespaces db db.sqlite smtp
|
|||
http.server
|
||||
http.server.dispatchers
|
||||
furnace.db
|
||||
furnace.flows
|
||||
furnace.asides
|
||||
furnace.flash
|
||||
furnace.sessions
|
||||
furnace.auth.login
|
||||
furnace.auth.providers.db
|
||||
|
|
@ -15,6 +16,7 @@ webapps.pastebin
|
|||
webapps.planet
|
||||
webapps.todo
|
||||
webapps.wiki
|
||||
webapps.wee-url
|
||||
webapps.user-admin ;
|
||||
IN: webapps.factor-website
|
||||
|
||||
|
|
@ -35,6 +37,8 @@ IN: webapps.factor-website
|
|||
|
||||
init-articles-table
|
||||
init-revisions-table
|
||||
|
||||
init-short-url-table
|
||||
] with-db ;
|
||||
|
||||
TUPLE: factor-website < dispatcher ;
|
||||
|
|
@ -45,6 +49,7 @@ TUPLE: factor-website < dispatcher ;
|
|||
<pastebin> "pastebin" add-responder
|
||||
<planet-factor> "planet" add-responder
|
||||
<wiki> "wiki" add-responder
|
||||
<wee-url> "wee-url" add-responder
|
||||
<user-admin> "user-admin" add-responder
|
||||
<login>
|
||||
users-in-db >>users
|
||||
|
|
@ -53,8 +58,7 @@ TUPLE: factor-website < dispatcher ;
|
|||
allow-edit-profile
|
||||
<boilerplate>
|
||||
{ factor-website "page" } >>template
|
||||
<flows>
|
||||
<sessions>
|
||||
<asides> <flash-scopes> <sessions>
|
||||
test-db <db-persistence> ;
|
||||
|
||||
: init-factor-website ( -- )
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue