From 6afa62b57cee77dae0c62ed4f192204127b3d402 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Apr 2008 20:19:54 -0500
Subject: [PATCH 1/9] Add RFC822 date parser
---
extra/calendar/calendar-tests.factor | 4 +
extra/calendar/calendar.factor | 35 +++---
extra/calendar/format/format-tests.factor | 33 ++++--
extra/calendar/format/format.factor | 100 +++++++++++++-----
.../{blog-summary.xml => blog-admin-link.xml} | 0
.../{mini-planet.xml => postings-summary.xml} | 0
6 files changed, 124 insertions(+), 48 deletions(-)
rename extra/webapps/planet/{blog-summary.xml => blog-admin-link.xml} (100%)
rename extra/webapps/planet/{mini-planet.xml => postings-summary.xml} (100%)
diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor
index e49d3ad894..c05d4f60eb 100755
--- a/extra/calendar/calendar-tests.factor
+++ b/extra/calendar/calendar-tests.factor
@@ -2,6 +2,10 @@ USING: arrays calendar kernel math sequences tools.test
continuations system ;
IN: calendar.tests
+\ time+ must-infer
+\ time* must-infer
+\ time- must-infer
+
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 8dcb4af7f1..2f93bf8218 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -211,12 +211,14 @@ M: duration time+
#! Uses average month/year length since dt loses calendar
#! data
0 swap
- [ year>> + ] keep
- [ month>> months-per-year / + ] keep
- [ day>> days-per-year / + ] keep
- [ hour>> hours-per-year / + ] keep
- [ minute>> minutes-per-year / + ] keep
- second>> seconds-per-year / + ;
+ {
+ [ year>> + ]
+ [ month>> months-per-year / + ]
+ [ day>> days-per-year / + ]
+ [ hour>> hours-per-year / + ]
+ [ minute>> minutes-per-year / + ]
+ [ second>> seconds-per-year / + ]
+ } cleave ;
M: duration <=> [ dt>years ] compare ;
@@ -252,14 +254,21 @@ M: timestamp time-
#! Exact calendar-time difference
(time-) seconds ;
+: time* ( obj1 obj2 -- obj3 )
+ dup real? [ swap ] when
+ dup real? [ * ] [
+ {
+ [ year>> * ]
+ [ month>> * ]
+ [ day>> * ]
+ [ hour>> * ]
+ [ minute>> * ]
+ [ second>> * ]
+ } 2cleave <duration>
+ ] if ;
+
: before ( dt -- -dt )
- [ year>> neg ] keep
- [ month>> neg ] keep
- [ day>> neg ] keep
- [ hour>> neg ] keep
- [ minute>> neg ] keep
- second>> neg
- <duration> ;
+ -1 time* ;
M: duration time-
before time+ ;
diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor
index 88bd0733c0..1ba892bef3 100755
--- a/extra/calendar/format/format-tests.factor
+++ b/extra/calendar/format/format-tests.factor
@@ -1,26 +1,45 @@
-USING: calendar.format calendar kernel tools.test
-io.streams.string ;
+USING: calendar.format calendar kernel math tools.test
+io.streams.string accessors io ;
IN: calendar.format.tests
[ 0 ] [
- "Z" [ read-rfc3339-gmt-offset ] with-string-reader
+ "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ 1 ] [
- "+01" [ read-rfc3339-gmt-offset ] with-string-reader
+ "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ -1 ] [
- "-01" [ read-rfc3339-gmt-offset ] with-string-reader
+ "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ -1-1/2 ] [
- "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+ "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ 1+1/2 ] [
- "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+ "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ ] [ now timestamp>rfc3339 drop ] unit-test
[ ] [ now timestamp>rfc822 drop ] unit-test
+
+[ 8/1000 -4 ] [
+ "2008-04-19T04:56:00.008-04:00" rfc3339>timestamp
+ [ second>> ] [ gmt-offset>> hour>> ] bi
+] unit-test
+
+[ T{ duration f 0 0 0 0 0 0 } ] [
+ "GMT" parse-rfc822-gmt-offset
+] unit-test
+
+[ T{ duration f 0 0 0 -5 0 0 } ] [
+ "-0500" parse-rfc822-gmt-offset
+] unit-test
+
+[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [
+ "Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp
+] unit-test
+
+[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test
diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor
index 26ed873fd3..7bdaea70b5 100755
--- a/extra/calendar/format/format.factor
+++ b/extra/calendar/format/format.factor
@@ -1,5 +1,6 @@
USING: math math.parser kernel sequences io calendar
-accessors arrays io.streams.string combinators accessors ;
+accessors arrays io.streams.string splitting
+combinators accessors debugger ;
IN: calendar.format
GENERIC: day. ( obj -- )
@@ -58,11 +59,11 @@ M: timestamp year. ( timestamp -- )
[ hour>> write-00 ] [ minute>> write-00 ] bi ;
: write-gmt-offset ( gmt-offset -- )
- dup instant <=> {
- { [ dup 0 = ] [ 2drop "GMT" write ] }
- { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }
- { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }
- } cond ;
+ dup instant <=> sgn {
+ { 0 [ drop "GMT" write ] }
+ { -1 [ "-" write before (write-gmt-offset) ] }
+ { 1 [ "+" write (write-gmt-offset) ] }
+ } case ;
: timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format
@@ -83,20 +84,22 @@ M: timestamp year. ( timestamp -- )
[ minute>> write-00 ] bi ;
: write-rfc3339-gmt-offset ( duration -- )
- dup instant <=> {
- { [ dup 0 = ] [ 2drop "Z" write ] }
- { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
- { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }
- } cond ;
+ dup instant <=> sgn {
+ { 0 [ drop "Z" write ] }
+ { -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
+ { 1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] }
+ } case ;
: (timestamp>rfc3339) ( timestamp -- )
- dup year>> number>string write CHAR: - write1
- dup month>> write-00 CHAR: - write1
- dup day>> write-00 CHAR: T write1
- dup hour>> write-00 CHAR: : write1
- dup minute>> write-00 CHAR: : write1
- dup second>> >fixnum write-00
- gmt-offset>> write-rfc3339-gmt-offset ;
+ {
+ [ year>> number>string write CHAR: - write1 ]
+ [ month>> write-00 CHAR: - write1 ]
+ [ day>> write-00 CHAR: T write1 ]
+ [ hour>> write-00 CHAR: : write1 ]
+ [ minute>> write-00 CHAR: : write1 ]
+ [ second>> >fixnum write-00 ]
+ [ gmt-offset>> write-rfc3339-gmt-offset ]
+ } cleave ;
: timestamp>rfc3339 ( timestamp -- str )
[ (timestamp>rfc3339) ] with-string-writer ;
@@ -106,14 +109,20 @@ M: timestamp year. ( timestamp -- )
: read-00 2 read string>number ;
+: read-000 3 read string>number ;
+
: read-0000 4 read string>number ;
-: read-rfc3339-gmt-offset ( -- n )
- read1 dup CHAR: Z = [ drop 0 ] [
- { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
- read-00
- read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
- 60 / + *
+: signed-gmt-offset ( dt ch -- dt' )
+ { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
+
+: read-rfc3339-gmt-offset ( ch -- dt )
+ dup CHAR: Z = [ drop instant ] [
+ >r
+ read-00 hours
+ read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
+ time+
+ r> signed-gmt-offset
] if ;
: read-ymd ( -- y m d )
@@ -126,26 +135,61 @@ M: timestamp year. ( timestamp -- )
read-ymd
"Tt" expect
read-hms
- read-rfc3339-gmt-offset ! timezone
+ read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
+ read-rfc3339-gmt-offset
<timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] with-string-reader ;
+ERROR: invalid-rfc822-date ;
+
+: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ;
+
+: read-token ( seps -- token )
+ [ read-until ] keep member? check-rfc822-date drop ;
+
+: read-sp ( -- token ) " " read-token ;
+
+: checked-number ( str -- n )
+ string>number check-rfc822-date ;
+
+: parse-rfc822-gmt-offset ( string -- dt )
+ dup "GMT" = [ drop instant ] [
+ unclip >r
+ 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
+ r> signed-gmt-offset
+ ] if ;
+
+: (rfc822>timestamp) ( -- timestamp )
+ timestamp new
+ "," read-token day-abbreviations3 member? check-rfc822-date drop
+ read1 CHAR: \s assert=
+ read-sp checked-number >>day
+ read-sp month-abbreviations index check-rfc822-date >>month
+ read-sp checked-number >>year
+ ":" read-token checked-number >>hour
+ ":" read-token checked-number >>minute
+ " " read-token checked-number >>second
+ readln parse-rfc822-gmt-offset >>gmt-offset ;
+
+: rfc822>timestamp ( str -- timestamp )
+ [ (rfc822>timestamp) ] with-string-reader ;
+
: (ymdhms>timestamp) ( -- timestamp )
- read-ymd " " expect read-hms 0 <timestamp> ;
+ read-ymd " " expect read-hms instant <timestamp> ;
: ymdhms>timestamp ( str -- timestamp )
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
- f f f read-hms f <timestamp> ;
+ f f f read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
- read-ymd f f f f <timestamp> ;
+ read-ymd f f f instant <timestamp> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;
diff --git a/extra/webapps/planet/blog-summary.xml b/extra/webapps/planet/blog-admin-link.xml
similarity index 100%
rename from extra/webapps/planet/blog-summary.xml
rename to extra/webapps/planet/blog-admin-link.xml
diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/postings-summary.xml
similarity index 100%
rename from extra/webapps/planet/mini-planet.xml
rename to extra/webapps/planet/postings-summary.xml
From bfa34122f3ac2eb429b33dd340dfebfaa4badff1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Apr 2008 20:23:49 -0500
Subject: [PATCH 2/9] Fix chunked encoding
---
extra/http/client/client.factor | 4 +--
extra/http/http.factor | 43 +++++++++++++++++++++++----------
2 files changed, 32 insertions(+), 15 deletions(-)
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index ac5d220a52..8879a76a5c 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -74,8 +74,8 @@ PRIVATE>
] with-variable ;
: read-chunks ( -- )
- readln ";" split1 drop hex>
- dup { f 0 } member? [ drop ] [ read % read-chunks ] if ;
+ read-crlf ";" split1 drop hex> dup { f 0 } member?
+ [ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
: do-chunked-encoding ( response stream -- response stream/string )
over "transfer-encoding" header "chunked" = [
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 5e90962b27..4aaab2205e 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -1,10 +1,18 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry hashtables io io.streams.string kernel math sets
-namespaces math.parser assocs sequences strings splitting ascii
-io.encodings.utf8 io.encodings.string io.sockets namespaces
-unicode.case combinators vectors sorting accessors calendar
-calendar.format quotations arrays combinators.lib byte-arrays ;
+USING: accessors kernel combinators math namespaces
+
+assocs sequences splitting sorting sets debugger
+strings vectors hashtables quotations arrays byte-arrays
+math.parser calendar calendar.format
+
+io io.streams.string io.encodings.utf8 io.encodings.string
+io.sockets
+
+unicode.case unicode.categories qualified ;
+
+EXCLUDE: fry => , ;
+
IN: http
: http-port 80 ; inline
@@ -13,11 +21,12 @@ IN: http
#! In a URL, can this character be used without
#! URL-encoding?
{
- [ dup letter? ]
- [ dup LETTER? ]
- [ dup digit? ]
- [ dup "/_-.:" member? ]
- } || nip ; foldable
+ { [ dup letter? ] [ t ] }
+ { [ dup LETTER? ] [ t ] }
+ { [ dup digit? ] [ t ] }
+ { [ dup "/_-.:" member? ] [ t ] }
+ [ f ]
+ } cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
@@ -75,8 +84,16 @@ IN: http
] if
] if ;
+: read-lf ( -- string )
+ "\n" read-until CHAR: \n assert= ;
+
+: read-crlf ( -- string )
+ "\r" read-until
+ CHAR: \r assert=
+ read1 CHAR: \n assert= ;
+
: read-header-line ( -- )
- readln dup
+ read-crlf dup
empty? [ drop ] [ header-line read-header-line ] if ;
: read-header ( -- assoc )
@@ -224,7 +241,7 @@ cookies ;
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
: read-request-version ( request -- request )
- readln [ CHAR: \s = ] left-trim
+ read-crlf [ CHAR: \s = ] left-trim
parse-version
>>version ;
@@ -372,7 +389,7 @@ body ;
>>code ;
: read-response-message
- readln >>message ;
+ read-crlf >>message ;
: read-response-header
read-header >>header
From f9ce5dd6c38ecbe1cd93af780a97e96e17a0ead4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Apr 2008 20:23:54 -0500
Subject: [PATCH 3/9] Fix RSS2.0 support
---
extra/rss/rss.factor | 14 +++++---------
1 file changed, 5 insertions(+), 9 deletions(-)
diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor
index 2e735d2f06..5fc688967a 100644
--- a/extra/rss/rss.factor
+++ b/extra/rss/rss.factor
@@ -23,7 +23,7 @@ C: <entry> entry
[ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named dup [ children>string rfc3339>timestamp ] when
+ tag-named dup [ children>string rfc822>timestamp ] when
<entry> ;
: rss1.0 ( xml -- feed )
@@ -39,7 +39,7 @@ C: <entry> entry
[ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string rfc3339>timestamp <entry> ;
+ "pubDate" tag-named children>string rfc822>timestamp <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
@@ -71,16 +71,12 @@ C: <entry> entry
{ "feed" [ atom1.0 ] }
} case ;
-: read-feed ( stream -- feed )
- [ read-xml ] with-html-entities xml>feed ;
+: 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-stream swap code>> success? [
- read-feed
- ] [
- dispose "Error retrieving newsfeed file" throw
- ] if ;
+ http-get read-feed ;
! Atom generation
: simple-tag, ( content name -- )
From 138cff4d47f9fd9e63d358e436592c53141d683c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 22 Apr 2008 21:06:24 -0500
Subject: [PATCH 4/9] stack effects for recusive words
---
extra/windows/windows.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor
index 0e555ed7e9..3e7520d406 100644
--- a/extra/windows/windows.factor
+++ b/extra/windows/windows.factor
@@ -30,10 +30,10 @@ FUNCTION: void* error_message ( DWORD id ) ;
: win32-error ( -- )
GetLastError (win32-error) ;
-: win32-error=0/f { 0 f } member? [ win32-error ] when ;
-: win32-error>0 0 > [ win32-error ] when ;
-: win32-error<0 0 < [ win32-error ] when ;
-: win32-error<>0 zero? [ win32-error ] unless ;
+: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
+: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
+: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
+: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
: invalid-handle? ( handle -- )
INVALID_HANDLE_VALUE = [
From 6e89f7b085bd2ec63948296344ff7f89375169a3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Apr 2008 21:08:27 -0500
Subject: [PATCH 5/9] Working on planet factor rewrite
---
extra/http/server/auth/login/login.factor | 2 +-
.../server/boilerplate/boilerplate.factor | 2 +-
.../http/server/components/components.factor | 29 +++++-
extra/http/server/forms/forms.factor | 2 +-
extra/http/server/server.factor | 29 +++---
.../http/server/templating/chloe/chloe.factor | 3 +-
.../http/server/templating/fhtml/fhtml.factor | 2 +-
.../http/server/templating/templating.factor | 17 +++-
.../factor-website/factor-website.factor | 38 ++++++++
.../{planet => factor-website}/page.xml | 35 ++++---
extra/webapps/planet/admin.xml | 13 +++
extra/webapps/planet/entry.xml | 14 ++-
extra/webapps/planet/planet.factor | 96 +++++++++++--------
extra/webapps/planet/planet.xml | 42 ++++----
extra/webapps/planet/postings.xml | 19 ++++
extra/webapps/todo/page.xml | 45 ---------
extra/webapps/todo/todo.css | 16 ----
extra/webapps/todo/todo.factor | 34 +------
18 files changed, 236 insertions(+), 202 deletions(-)
create mode 100644 extra/webapps/factor-website/factor-website.factor
rename extra/webapps/{planet => factor-website}/page.xml (89%)
create mode 100644 extra/webapps/planet/admin.xml
create mode 100644 extra/webapps/planet/postings.xml
delete mode 100644 extra/webapps/todo/page.xml
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index b0cc0c21d1..7593f217f7 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -363,7 +363,7 @@ M: login call-responder ( path responder -- response )
: <login> ( responder -- auth )
login new-dispatcher
- swap <protected> >>default
+ swap >>default
<login-action> <login-boilerplate> "login" add-responder
<logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ;
diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor
index 6c62452ec2..eabcefeb7f 100644
--- a/extra/http/server/boilerplate/boilerplate.factor
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -48,7 +48,7 @@ SYMBOL: next-template
: call-next-template ( -- )
next-template get write ;
-M: f call-template drop call-next-template ;
+M: f call-template* drop call-next-template ;
: with-boilerplate ( body template -- )
[
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index bdcdd95c71..331231dfb3 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -280,6 +280,22 @@ TUPLE: date < string ;
M: date component-string
drop timestamp>string ;
+! Link components
+
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link-renderer
+
+M: link-renderer render-view*
+ drop <a dup link-href =href a> link-title write </a> ;
+
+TUPLE: link < string ;
+
+: <link> ( id -- component )
+ link new-string
+ link-renderer >>renderer ;
+
! List components
SYMBOL: +plain+
SYMBOL: +ordered+
@@ -289,17 +305,20 @@ TUPLE: list-renderer component type ;
C: <list-renderer> list-renderer
-: render-plain-list ( seq quot component -- )
- swap '[ , @ ] each ; inline
+: render-plain-list ( seq component quot -- )
+ '[ , component>> renderer>> @ ] each ; inline
+
+: render-li-list ( seq component quot -- )
+ '[ <li> @ </li> ] render-plain-list ; inline
: render-ordered-list ( seq quot component -- )
- swap <ol> '[ <li> , @ </li> ] each </ol> ; inline
+ <ol> render-li-list </ol> ; inline
: render-unordered-list ( seq quot component -- )
- swap <ul> '[ <li> , @ </li> ] each </ul> ; inline
+ <ul> render-li-list </ul> ; inline
: render-list ( value renderer quot -- )
- swap [ component>> ] [ type>> ] bi {
+ over type>> {
{ +plain+ [ render-plain-list ] }
{ +ordered+ [ render-ordered-list ] }
{ +unordered+ [ render-unordered-list ] }
diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor
index f45bf6ec65..60f3da25b6 100644
--- a/extra/http/server/forms/forms.factor
+++ b/extra/http/server/forms/forms.factor
@@ -78,4 +78,4 @@ M: form render-view*
dup view-template>> render-form ;
M: form render-edit*
- dup edit-template>> render-form ;
+ nip dup edit-template>> render-form ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index db03645a24..d3bd6c6bbe 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -160,23 +160,30 @@ drop
SYMBOL: development-mode
+: http-error. ( error -- )
+ "Internal server error" [
+ development-mode get [
+ [ print-error nl :c ] with-html-stream
+ ] [
+ 500 "Internal server error"
+ trivial-response-body
+ ] if
+ ] simple-page ;
+
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- swap '[
- , "Internal server error" [
- development-mode get [
- [ print-error nl :c ] with-html-stream
- ] [
- 500 "Internal server error"
- trivial-response-body
- ] if
- ] simple-page
- ] >>body ;
+ swap '[ , http-error. ] >>body ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" =
- [ drop ] [ write-response-body ] if ;
+ [ drop ] [
+ '[
+ , write-response-body
+ ] [
+ http-error.
+ ] recover
+ ] if ;
LOG: httpd-hit NOTICE
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
index 8142c5e3b7..685988dfaf 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -153,6 +153,7 @@ SYMBOL: tags
{ "form" [ form-tag ] }
{ "error" [ error-tag ] }
{ "if" [ if-tag ] }
+ { "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
[ "Unknown chloe tag: " swap append throw ]
} case ;
@@ -189,7 +190,7 @@ SYMBOL: tags
] if
] with-scope ;
-M: chloe call-template
+M: chloe call-template*
path>> utf8 <file-reader> read-xml process-chloe ;
INSTANCE: chloe template
diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor
index 1cba4b9b2e..2cc053a0ca 100755
--- a/extra/http/server/templating/fhtml/fhtml.factor
+++ b/extra/http/server/templating/fhtml/fhtml.factor
@@ -76,7 +76,7 @@ TUPLE: fhtml path ;
C: <fhtml> fhtml
-M: fhtml call-template ( filename -- )
+M: fhtml call-template* ( filename -- )
'[
, path>> [
"quiet" on
diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor
index f69dd9bfe0..610ec78fed 100644
--- a/extra/http/server/templating/templating.factor
+++ b/extra/http/server/templating/templating.factor
@@ -1,10 +1,21 @@
-USING: accessors kernel fry io.encodings.utf8 io.files
-http http.server ;
+USING: accessors kernel fry io io.encodings.utf8 io.files
+http http.server debugger prettyprint continuations ;
IN: http.server.templating
MIXIN: template
-GENERIC: call-template ( template -- )
+GENERIC: call-template* ( template -- )
+
+ERROR: template-error template error ;
+
+M: template-error error.
+ "Error while processing template " write
+ [ template>> pprint ":" print nl ]
+ [ error>> error. ]
+ bi ;
+
+: call-template ( template -- )
+ [ call-template* ] [ template-error ] recover ;
M: template write-response-body* call-template ;
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
new file mode 100644
index 0000000000..3483d4321e
--- /dev/null
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -0,0 +1,38 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences io.files io.sockets
+db.sqlite smtp namespaces db
+http.server.db
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db
+http.server.boilerplate
+http.server.templating.chloe ;
+IN: webapps.factor-website
+
+: factor-template ( path -- template )
+ "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
+
+: test-db "todo.db" resource-path sqlite-db ;
+
+: <factor-boilerplate> ( responder -- responder' )
+ <login>
+ users-in-db >>users
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ <boilerplate>
+ "page" factor-template >>template
+ <url-sessions>
+ sessions-in-db >>sessions
+ test-db <db-persistence> ;
+
+: init-factor-website ( -- )
+ "factorcode.org" 25 <inet> smtp-server set-global
+ "todo@factorcode.org" lost-password-from set-global
+
+ test-db [
+ init-sessions-table
+ init-users-table
+ ] with-db ;
diff --git a/extra/webapps/planet/page.xml b/extra/webapps/factor-website/page.xml
similarity index 89%
rename from extra/webapps/planet/page.xml
rename to extra/webapps/factor-website/page.xml
index 1278c8174c..d929042320 100644
--- a/extra/webapps/planet/page.xml
+++ b/extra/webapps/factor-website/page.xml
@@ -10,52 +10,49 @@
<head>
<t:write-title />
- <t:write-atom />
-
<t:style>
+ body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+ }
+
.link-button {
padding: 0px;
background: none;
border: none;
}
- .inline {
- display: inline;
- }
-
- body, button {
- font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#444;
- }
-
a, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
}
- h1 a {
- border: none;
- }
-
a:hover, .link:hover {
border-bottom:1px solid #66a;
}
.error { color: #a00; }
-
+
.field-label {
text-align: right;
}
+
+ .inline {
+ display: inline;
+ }
+
+ .navbar {
+ background-color: #eee;
+ padding: 5px;
+ border: 1px solid #ccc;
+ }
</t:style>
<t:write-style />
</head>
<body>
-
- <h1><t:a href="planet"><t:write-title /></t:a></h1>
-
<t:call-next-template />
</body>
diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml
new file mode 100644
index 0000000000..1a18cad94b
--- /dev/null
+++ b/extra/webapps/planet/admin.xml
@@ -0,0 +1,13 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Planet Factor Administration</t:title>
+
+ <t:summary component="blogroll" />
+
+ <p>
+ <t:a href="edit-blog">Add Blog</t:a> | <t:a href="update">Update</t:a>
+ </p>
+
+</t:chloe>
diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml
index a9383d16f2..bc89af3263 100644
--- a/extra/webapps/planet/entry.xml
+++ b/extra/webapps/planet/entry.xml
@@ -2,8 +2,16 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <h2 class="posting-title"><t:view component="title" /></h2>
- <p class="posting-body"> <t:view component="description" /> </p>
- <p class="posting-date"> <t:view component="pub-date" /> </p>
+ <h2 class="posting-title">
+ <t:a value="link"><t:view component="title" /></t:a>
+ </h2>
+
+ <p class="posting-body">
+ <t:view component="description" />
+ </p>
+
+ <p class="posting-date">
+ <t:a value="link"><t:view component="pub-date" /></t:a>
+ </p>
</t:chloe>
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 966bcc1d0b..464e2bbfb3 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math
-calendar alarms logging concurrency.combinators
+calendar alarms logging concurrency.combinators namespaces
db.types db.tuples db
rss xml.writer
http.server
@@ -10,11 +10,22 @@ http.server.forms
http.server.actions
http.server.boilerplate
http.server.templating.chloe
-http.server.components ;
+http.server.components
+http.server.auth.login
+webapps.factor-website ;
IN: webapps.planet
+TUPLE: planet-factor < dispatcher postings ;
+
+: planet-template ( name -- template )
+ "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+
TUPLE: blog id name www-url atom-url ;
+M: blog link-title name>> ;
+
+M: blog link-href www-url>> ;
+
blog "BLOGS"
{
{ "id" "ID" INTEGER +native-id+ }
@@ -29,8 +40,8 @@ blog "BLOGS"
blog new
swap >>id ;
-: planet-template ( name -- template )
- "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+: blogroll ( -- seq )
+ f <blog> select-tuples [ [ name>> ] compare ] sort ;
: <entry-form> ( -- form )
"entry" <form>
@@ -44,7 +55,7 @@ blog "BLOGS"
"blog" <form>
"edit-blog" planet-template >>edit-template
"view-blog" planet-template >>view-template
- "blog-summary" planet-template >>summary-template
+ "blog-admin-link" planet-template >>summary-template
"id" <integer>
hidden >>renderer
add-field
@@ -60,15 +71,27 @@ blog "BLOGS"
: <planet-factor-form> ( -- form )
"planet-factor" <form>
- "planet" planet-template >>view-template
- "mini-planet" planet-template >>summary-template
+ "postings" planet-template >>view-template
+ "postings-summary" planet-template >>summary-template
"postings" <entry-form> +plain+ <list> add-field
+ "blogroll" "blog" <link> +unordered+ <list> add-field ;
+
+: <admin-form> ( -- form )
+ "admin" <form>
+ "admin" planet-template >>view-template
"blogroll" <blog-form> +unordered+ <list> add-field ;
-: blogroll ( -- seq )
- f <blog> select-tuples [ [ name>> ] compare ] sort ;
+:: <edit-blogroll-action> ( planet -- action )
+ [let | form [ <admin-form> ] |
+ <action>
+ [
+ blank-values
-TUPLE: planet-factor < dispatcher postings ;
+ blogroll "blogroll" set-value
+
+ form view-form
+ ] >>display
+ ] ;
:: <planet-action> ( planet -- action )
[let | form [ <planet-factor-form> ] |
@@ -90,7 +113,7 @@ TUPLE: planet-factor < dispatcher postings ;
feed new
"[ planet-factor ]" >>title
"http://planet.factorcode.org" >>link
- planet postings>> 30 safe-head >>entries ;
+ planet postings>> 16 safe-head >>entries ;
:: <feed-action> ( planet -- action )
<action>
@@ -117,7 +140,8 @@ TUPLE: planet-factor < dispatcher postings ;
: update-cached-postings ( planet -- )
"webapps.planet" [
- blogroll fetch-blogroll sort-entries >>postings drop
+ blogroll fetch-blogroll sort-entries 8 safe-head
+ >>postings drop
] with-logging ;
:: <update-action> ( planet -- action )
@@ -127,16 +151,11 @@ TUPLE: planet-factor < dispatcher postings ;
"" f <temporary-redirect>
] >>display ;
-: start-update-task ( planet -- )
- [ update-cached-postings ] curry 10 minutes every drop ;
-
-:: <planet-factor> ( -- responder )
+:: <planet-factor-admin> ( planet-factor -- responder )
[let | blog-form [ <blog-form> ]
blog-ctor [ [ <blog> ] ] |
- planet-factor new-dispatcher
- dup <planet-action> >>default
- dup <feed-action> "feed.xml" add-responder
- dup <update-action> "update" add-responder
+ <dispatcher>
+ planet-factor <edit-blogroll-action> >>default
! Administrative CRUD
blog-ctor "" <delete-action> "delete-blog" add-responder
@@ -144,30 +163,25 @@ TUPLE: planet-factor < dispatcher postings ;
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
] ;
-USING: namespaces io.files io.sockets
-db.sqlite smtp
-http.server.db
-http.server.sessions
-http.server.auth.login
-http.server.auth.providers.db
-http.server.sessions.storage.db ;
-
-: test-db "planet.db" resource-path sqlite-db ;
-
-: <planet-app> ( -- responder )
- <planet-factor>
+: <planet-factor> ( -- responder )
+ planet-factor new-dispatcher
+ dup <planet-action> >>default
+ dup <feed-action> "feed.xml" add-responder
+ dup <update-action> "update" add-responder
+ dup <planet-factor-admin> <protected> "admin" add-responder
<boilerplate>
- "page" planet-template >>template
- ! <url-sessions>
- ! sessions-in-db >>sessions
- test-db <db-persistence> ;
+ "planet" planet-template >>template ;
+
+: <planet-app> ( -- responder )
+ <planet-factor> <factor-boilerplate> ;
+
+: start-update-task ( planet -- )
+ [ update-cached-postings ] curry 10 minutes every drop ;
: init-planet ( -- )
- ! test-db [
- ! init-blog-table
- ! init-users-table
- ! init-sessions-table
- ! ] with-db
+ test-db [
+ init-blog-table
+ ] with-db
<dispatcher>
<planet-app> "planet" add-responder
diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml
index dc762fafc6..772f81906d 100644
--- a/extra/webapps/planet/planet.xml
+++ b/extra/webapps/planet/planet.xml
@@ -2,36 +2,30 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Planet Factor</t:title>
-
+<t:comment>
<t:atom title="Planet Factor - Atom" href="feed.xml" />
-
+</t:comment>
<t:style include="resource:extra/webapps/planet/planet.css" />
- <table width="100%" cellpadding="10">
- <tr>
- <td> <t:view component="postings" /> </td>
+ <div class="navbar">
+ <t:a href="list">Front Page</t:a>
+ | <t:a href="feed.xml">Atom Feed</t:a>
- <td valign="top" width="25%" class="infobox">
- <p>
- <strong>planet-factor</strong> is an Atom feed aggregator that collects the
- contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It was inspired by
- <a href="http://planet.lisp.org">Planet Lisp</a>.
- </p>
- <p>
- <img src="http://planet.lisp.org/feed-icon-14x14.png" />
- <a href="feed.xml"> Syndicate </a>
- </p>
+ | <t:a href="admin">Admin</t:a>
- <h2>Blogroll</h2>
+ <t:comment>
+ <t:if code="http.server.auth.login:allow-edit-profile?">
+ | <t:a href="edit-profile">Edit Profile</t:a>
+ </t:if>
- <t:summary component="blogroll" />
+ <t:form action="logout" class="inline">
+ | <button type="submit" class="link-button link">Logout</button>
+ </t:form>
+ </t:comment>
+ </div>
- Admin: <t:a href="edit-blog">Add Blog</t:a>
- |
- <t:a href="update">Update</t:a>
- </td>
- </tr>
- </table>
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
</t:chloe>
diff --git a/extra/webapps/planet/postings.xml b/extra/webapps/planet/postings.xml
new file mode 100644
index 0000000000..f59a4f61b8
--- /dev/null
+++ b/extra/webapps/planet/postings.xml
@@ -0,0 +1,19 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Planet Factor</t:title>
+
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td> <t:view component="postings" /> </td>
+
+ <td valign="top" width="25%" class="infobox">
+ <h2>Blogroll</h2>
+
+ <t:summary component="blogroll" />
+ </td>
+ </tr>
+ </table>
+
+</t:chloe>
diff --git a/extra/webapps/todo/page.xml b/extra/webapps/todo/page.xml
deleted file mode 100644
index f40c79d299..0000000000
--- a/extra/webapps/todo/page.xml
+++ /dev/null
@@ -1,45 +0,0 @@
-<?xml version='1.0' ?>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-
- <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <head>
- <t:write-title />
-
- <t:style>
- body, button {
- font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#444;
- }
-
- a, .link {
- color: #222;
- border-bottom:1px dotted #666;
- text-decoration:none;
- }
-
- a:hover, .link:hover {
- border-bottom:1px solid #66a;
- }
-
- .error { color: #a00; }
-
- .field-label {
- text-align: right;
- }
- </t:style>
-
- <t:write-style />
- </head>
-
- <body>
- <t:call-next-template />
- </body>
-
- </t:chloe>
-
-</html>
diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css
index c2e8a7fd79..2520a56128 100644
--- a/extra/webapps/todo/todo.css
+++ b/extra/webapps/todo/todo.css
@@ -10,22 +10,6 @@
color: #000000;
}
-.link-button {
- padding: 0px;
- background: none;
- border: none;
-}
-
-.navbar {
- background-color: #eeeeee;
- padding: 5px;
- border: 1px solid #ccc;
-}
-
-.inline {
- display: inline;
-}
-
pre {
font-size: 75%;
}
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 917b9bf7a7..08555b92ed 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -1,12 +1,13 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals sequences
+USING: accessors kernel locals sequences namespaces
db db.types db.tuples
http.server.components http.server.components.farkup
http.server.forms http.server.templating.chloe
http.server.boilerplate http.server.crud http.server.auth
http.server.actions http.server.db
-http.server ;
+http.server
+webapps.factor-website ;
IN: webapps.todo
TUPLE: todo uid id priority summary description ;
@@ -71,37 +72,10 @@ TUPLE: todo-responder < dispatcher ;
"todo" todo-template >>template
] ;
-! What follows below is somewhat akin to a 'deployment descriptor'
-! for the todo application. The <todo-responder> can be integrated
-! into an existing web app that provides session management and
-! login facilities, or <todo-app> can be used to run a
-! self-contained todo instance.
-USING: namespaces io.files io.sockets
-db.sqlite smtp
-http.server.sessions
-http.server.auth.login
-http.server.auth.providers.db
-http.server.sessions.storage.db ;
-
-: test-db "todo.db" resource-path sqlite-db ;
-
: <todo-app> ( -- responder )
- <todo-responder>
- <login>
- users-in-db >>users
- allow-registration
- allow-password-recovery
- allow-edit-profile
- <boilerplate>
- "page" todo-template >>template
- <url-sessions>
- sessions-in-db >>sessions
- test-db <db-persistence> ;
+ <todo-responder> <protected> <factor-boilerplate> ;
: init-todo ( -- )
- "factorcode.org" 25 <inet> smtp-server set-global
- "todo@factorcode.org" lost-password-from set-global
-
test-db [
init-todo-table
init-users-table
From 6a0dc9f02451015d909f8941594a27250f89b4b6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 23 Apr 2008 00:07:26 -0500
Subject: [PATCH 6/9] fix unit tests
---
extra/db/tuples/tuples-tests.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 1c900edc68..32562a4ae8 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -80,9 +80,9 @@ SYMBOL: person4
"teddy"
10
3.14
- T{ timestamp f 2008 3 5 16 24 11 0 }
- T{ timestamp f 2008 11 22 f f f f }
- T{ timestamp f f f f 12 34 56 f }
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
}
] [ T{ person f 3 } select-tuple ] unit-test
@@ -96,9 +96,9 @@ SYMBOL: person4
"eddie"
10
3.14
- T{ timestamp f 2008 3 5 16 24 11 0 }
- T{ timestamp f 2008 11 22 f f f f }
- T{ timestamp f f f f 12 34 56 f }
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f
H{ { 1 2 } { 3 4 } { 5 "lol" } }
}
From f9659ecc7c412eaf986d14fd19b6d29c6de3d230 Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@galois.com>
Date: Tue, 22 Apr 2008 23:45:30 -0700
Subject: [PATCH 7/9] Add sequences.lib.replicate
---
extra/sequences/lib/lib.factor | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index b186ee7777..c648660d66 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -131,6 +131,10 @@ MACRO: firstn ( n -- )
[ find drop [ head-slice ] when* ] curry
[ dup ] swap compose keep like ;
+: replicate ( seq quot -- newseq )
+ #! quot: ( -- obj )
+ [ drop ] swap compose map ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
From 916ed96ffb81b052ad9cdcbb41e982a64664c0ae Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@gmail.com>
Date: Tue, 22 Apr 2008 01:44:50 -0700
Subject: [PATCH 8/9] Add project-euler.151
---
extra/project-euler/151/151.factor | 40 ++++++++++++++++++++++++++++++
1 file changed, 40 insertions(+)
create mode 100644 extra/project-euler/151/151.factor
diff --git a/extra/project-euler/151/151.factor b/extra/project-euler/151/151.factor
new file mode 100644
index 0000000000..85aad116b4
--- /dev/null
+++ b/extra/project-euler/151/151.factor
@@ -0,0 +1,40 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences combinators kernel sequences.lib math assocs namespaces ;
+IN: project-euler.151
+
+SYMBOL: table
+
+: (pick-sheet) ( seq i -- newseq )
+ [
+ <=> sgn
+ {
+ { -1 [ ] }
+ { 0 [ 1- ] }
+ { 1 [ 1+ ] }
+ } case
+ ] curry map-index ;
+
+DEFER: (euler151)
+
+: pick-sheet ( seq i -- res )
+ 2dup swap nth dup zero? [
+ 3drop 0
+ ] [
+ [ (pick-sheet) (euler151) ] dip *
+ ] if ;
+
+: (euler151) ( x -- y )
+ table get [ {
+ { { 0 0 0 1 } [ 0 ] }
+ { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1+ ] }
+ { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1+ ] }
+ { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1+ ] }
+ [ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
+ } case ] cache ;
+
+: euler151 ( -- n )
+ [
+ H{ } clone table set
+ { 1 1 1 1 } (euler151)
+ ] with-scope ;
From 57a15fb363f5f03c8f49e033879bb755763d9299 Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@gmail.com>
Date: Tue, 22 Apr 2008 01:45:29 -0700
Subject: [PATCH 9/9] Add project-euler.100
---
extra/project-euler/100/100.factor | 7 +++++++
1 file changed, 7 insertions(+)
create mode 100644 extra/project-euler/100/100.factor
diff --git a/extra/project-euler/100/100.factor b/extra/project-euler/100/100.factor
new file mode 100644
index 0000000000..d2d396a0e1
--- /dev/null
+++ b/extra/project-euler/100/100.factor
@@ -0,0 +1,7 @@
+USING: kernel sequences math.functions math ;
+IN: project-euler.100
+
+: euler100 ( -- n )
+ 1 1
+ [ dup dup 1- * 2 * 10 24 ^ <= ]
+ [ tuck 6 * swap - 2 - ] [ ] while nip ;