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

Conflicts:

	extra/pango/cairo/gadgets/gadgets.factor
db4
Matthew Willis 2008-06-06 12:17:22 -07:00
commit 1f6530b16e
127 changed files with 2488 additions and 1360 deletions

View File

@ -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

View File

@ -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 -- )" } } }

View File

@ -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:

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 )

View File

@ -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>

View File

@ -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 ;

View File

@ -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* ;

View File

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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 } ;

View File

@ -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

View File

@ -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 ;

View File

@ -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>

View File

@ -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>

View File

@ -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>

View File

@ -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 ;

View File

@ -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

View File

@ -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* ;

View File

@ -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 ;

View File

@ -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 )

View File

@ -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

View File

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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

1
extra/lists/authors.txt Normal file
View File

@ -0,0 +1 @@
James Cash

View File

@ -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 ;

View File

@ -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 } ;

View File

@ -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

View File

@ -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

View File

@ -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." } ;

View File

@ -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

107
extra/lists/lists.factor Normal file
View File

@ -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

1
extra/lists/summary.txt Normal file
View File

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

3
extra/lists/tags.txt Normal file
View File

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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 -- )

View File

@ -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" } } ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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"

View File

@ -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

View File

@ -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

View File

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

View File

@ -0,0 +1 @@
collections

View File

@ -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 "" ;

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -1 +0,0 @@
Daniel Ehrenberg

View File

@ -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* ;

3
extra/syndication/authors.txt Executable file
View File

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

View File

@ -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

View File

@ -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* ;

View File

@ -0,0 +1 @@
web

View File

@ -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? ;

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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