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 01/11] 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 02/11] 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 03/11] 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 04/11] 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 05/11] 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 06/11] 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 07/11] 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 857ecda0eb1454d95b2997b4d9f82d921291b220 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 24 Apr 2008 02:48:48 -0500
Subject: [PATCH 08/11] Improve error messages for mirrors

---
 core/debugger/debugger.factor     |  6 +++++-
 core/mirrors/mirrors-docs.factor  |  4 ----
 core/mirrors/mirrors-tests.factor | 14 +++++++++++++-
 core/mirrors/mirrors.factor       | 29 ++++++++++++++---------------
 4 files changed, 32 insertions(+), 21 deletions(-)

diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 827a5c4e8d..f2740a63a9 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
 classes.tuple continuations continuations.private combinators
 generic.math io.streams.duplex classes.builtin classes
 compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings accessors ;
+init kernel.private libc io.encodings mirrors accessors ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -289,6 +289,10 @@ M: encode-error summary drop "Character encoding error" ;
 
 M: decode-error summary drop "Character decoding error" ;
 
+M: no-such-slot summary drop "No such slot" ;
+
+M: immutable-slot summary drop "Slot is immutable" ;
+
 <PRIVATE
 
 : init-debugger ( -- )
diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor
index dc4315fb39..e3ebfefa5f 100755
--- a/core/mirrors/mirrors-docs.factor
+++ b/core/mirrors/mirrors-docs.factor
@@ -37,10 +37,6 @@ HELP: <mirror>
     }
 } ;
 
-HELP: >mirror<
-{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
-
 HELP: make-mirror
 { $values { "obj" object } { "assoc" assoc } }
 { $description "Creates an assoc which reflects the internal structure of the object." } ;
diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor
index 11e5772000..45970c8bae 100755
--- a/core/mirrors/mirrors-tests.factor
+++ b/core/mirrors/mirrors-tests.factor
@@ -1,4 +1,4 @@
-USING: mirrors tools.test assocs kernel arrays ;
+USING: mirrors tools.test assocs kernel arrays accessors ;
 IN: mirrors.tests
 
 TUPLE: foo bar baz ;
@@ -14,3 +14,15 @@ C: <foo> foo
 [ 3 ] [
     3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
 ] unit-test
+
+[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
+    [ no-such-slot? ]
+    [ name>> "hi" = ]
+    [ object>> foo? ] tri and and
+] must-fail-with
+
+[ 3 "numerator" 1/2 <mirror> set-at ] [
+    [ immutable-slot? ]
+    [ name>> "numerator" = ]
+    [ object>> 1/2 = ] tri and and
+] must-fail-with
diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor
index 02afaf07fc..0a49163075 100755
--- a/core/mirrors/mirrors.factor
+++ b/core/mirrors/mirrors.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs hashtables kernel sequences generic words
 arrays classes slots slots.private classes.tuple math vectors
-quotations sorting prettyprint ;
+quotations sorting prettyprint accessors ;
 IN: mirrors
 
 : all-slots ( class -- slots )
@@ -16,33 +16,32 @@ TUPLE: mirror object slots ;
 : <mirror> ( object -- mirror )
     dup object-slots mirror boa ;
 
-: >mirror< ( mirror -- obj slots )
-    dup mirror-object swap mirror-slots ;
+ERROR: no-such-slot object name ;
 
-: mirror@ ( slot-name mirror -- obj slot-spec )
-    >mirror< swapd slot-named ;
+ERROR: immutable-slot object name ;
 
 M: mirror at*
-    mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
+    [ nip object>> ] [ slots>> slot-named ] 2bi
+    dup [ offset>> slot t ] [ 2drop f f ] if ;
 
 M: mirror set-at ( val key mirror -- )
-    mirror@ dup [
-        dup slot-spec-writer [
-            slot-spec-offset set-slot
+    [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
+        dup writer>> [
+            nip offset>> set-slot
         ] [
-            "Immutable slot" throw
+            drop immutable-slot
         ] if
     ] [
-        "No such slot" throw
+        drop no-such-slot
     ] if ;
 
 M: mirror delete-at ( key mirror -- )
     f -rot set-at ;
 
 M: mirror >alist ( mirror -- alist )
-    >mirror<
-    [ [ slot-spec-offset slot ] with map ] keep
-    [ slot-spec-name ] map swap zip ;
+    [ slots>> [ name>> ] map ]
+    [ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
+    zip ;
 
 M: mirror assoc-size mirror-slots length ;
 
@@ -50,7 +49,7 @@ INSTANCE: mirror assoc
 
 : sort-assoc ( assoc -- alist )
     >alist
-    [ dup first unparse-short swap ] { } map>assoc
+    [ [ first unparse-short ] keep ] { } map>assoc
     sort-keys values ;
 
 GENERIC: make-mirror ( obj -- assoc )

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 09/11] 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 10/11] 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 ;

From 6fa498f5cb2d653583f32cb932120bfb0ee8b60c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 24 Apr 2008 14:49:31 -0500
Subject: [PATCH 11/11] Add 'short' word

---
 extra/sequences/lib/lib.factor | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index b186ee7777..40768e58e2 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -236,3 +236,6 @@ PRIVATE>
 
 : remove-nth ( seq n -- seq' )
     cut-slice 1 tail-slice append ;
+
+: short ( seq n -- seq n' )
+    over length min ; inline