diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index cbddfa7d28..4153430514 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -680,7 +680,7 @@ PRIVATE> : unclip ( seq -- rest first ) [ rest ] [ first ] bi ; -: unclip-last ( seq -- butfirst last ) +: unclip-last ( seq -- butlast last ) [ but-last ] [ peek ] bi ; : unclip-slice ( seq -- rest first ) diff --git a/core/splitting/splitting-docs.factor b/core/splitting/splitting-docs.factor index 5000dbf5fd..1beafc710a 100644 --- a/core/splitting/splitting-docs.factor +++ b/core/splitting/splitting-docs.factor @@ -1,6 +1,25 @@ USING: help.markup help.syntax sequences strings ; IN: splitting +ARTICLE: "groups-clumps" "Groups and clumps" +"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:" +{ $subsection groups } +{ $subsection } +{ $subsection } +"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" +{ $subsection clumps } +{ $subsection } +{ $subsection } +"The difference can be summarized as the following:" +{ $list + { "With groups, the subsequences form the original sequence when concatenated:" + { $unchecked-example "dup n groups concat sequence= ." "t" } + } + { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:" + { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" } + } +} ; + ARTICLE: "sequences-split" "Splitting sequences" "Splitting sequences at occurrences of subsequences:" { $subsection ?head } @@ -9,14 +28,9 @@ ARTICLE: "sequences-split" "Splitting sequences" { $subsection ?tail-slice } { $subsection split1 } { $subsection split } -"Grouping elements:" -{ $subsection group } -"A virtual sequence for grouping elements:" -{ $subsection groups } -{ $subsection } -{ $subsection } "Splitting a string into lines:" -{ $subsection string-lines } ; +{ $subsection string-lines } +{ $subsection "groups-clumps" } ; ABOUT: "sequences-split" @@ -36,19 +50,22 @@ HELP: split { $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ; HELP: groups -{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively." +{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively." $nl "New groups are created by calling " { $link } " and " { $link } "." } { $see-also group } ; HELP: group { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } -{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." } -{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ; +{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." } +{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } +{ $examples + { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" } +} ; HELP: { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } } -{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." } +{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example "USING: arrays kernel prettyprint sequences splitting ;" @@ -58,7 +75,7 @@ HELP: HELP: { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } } -{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." } +{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example "USING: arrays kernel prettyprint sequences splitting ;" @@ -68,7 +85,46 @@ HELP: } } ; -{ group } related-words +HELP: clumps +{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively." +$nl +"New clumps are created by calling " { $link } " and " { $link } "." } ; + +HELP: clump +{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } +{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." } +{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." } +{ $examples + { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" } +} ; + +HELP: +{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } } +{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } +{ $examples + "Running averages:" + { $example + "USING: splitting sequences math prettyprint kernel ;" + "IN: scratchpad" + ": share-price" + " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;" + "" + "share-price 4 [ [ sum ] [ length ] bi / ] map ." + "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }" + } +} ; + +HELP: +{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } } +{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ; + +{ clumps groups } related-words + +{ clump group } related-words + +{ } related-words + +{ } related-words HELP: ?head { $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } } diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 9f6ae75d32..62e7ef3782 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -44,7 +44,7 @@ M: sliced-groups nth group@ ; TUPLE: clumps < abstract-groups ; -: ( seq n -- groups ) +: ( seq n -- clumps ) clumps construct-groups ; inline M: clumps length @@ -58,7 +58,7 @@ M: clumps group@ TUPLE: sliced-clumps < groups ; -: ( seq n -- groups ) +: ( seq n -- clumps ) sliced-clumps construct-groups ; inline M: sliced-clumps nth group@ ; diff --git a/extra/http/server/auth/admin/admin.factor b/extra/http/server/auth/admin/admin.factor deleted file mode 100644 index 21e1a6181b..0000000000 --- a/extra/http/server/auth/admin/admin.factor +++ /dev/null @@ -1,179 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors namespaces combinators words -assocs locals db.tuples arrays splitting strings qualified - -http.server.templating.chloe -http.server.boilerplate -http.server.auth.providers -http.server.auth.providers.db -http.server.auth.login -http.server.auth -http.server.forms -http.server.components.inspector -http.server.validators -http.server.sessions -http.server.actions -http.server.crud -http.server ; -EXCLUDE: http.server.components => string? number? ; -IN: http.server.auth.admin - -: admin-template ( name -- template ) - "resource:extra/http/server/auth/admin/" swap ".xml" 3append ; - -: words>strings ( seq -- seq' ) - [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ; - -: strings>words ( seq -- seq' ) - [ ":" split1 swap lookup ] map ; - -: ( id -- component ) - capabilities get words>strings ; - -: ( -- form ) - "user"
- "new-user" admin-template >>edit-template - "username" add-field - "realname" add-field - "new-password" t >>required add-field - "verify-password" t >>required add-field - "email" add-field - "capabilities" add-field ; - -: ( -- form ) - "user" - "edit-user" admin-template >>edit-template - "user-summary" admin-template >>summary-template - "username" hidden >>renderer add-field - "realname" add-field - "new-password" add-field - "verify-password" add-field - "email" add-field - "profile" add-field - "capabilities" add-field ; - -: ( -- form ) - "user-list" - "user-list" admin-template >>view-template - "list" +unordered+ add-field ; - -:: ( form ctor next -- action ) - - [ - blank-values - - "username" get ctor call - - { - [ username>> "username" set-value ] - [ realname>> "realname" set-value ] - [ email>> "email" set-value ] - [ profile>> "profile" set-value ] - } cleave - ] >>init - - [ form edit-form ] >>display - - [ - blank-values - - form validate-form - - same-password-twice - - user new "username" value >>username select-tuple - [ user-exists ] when - - "username" value - "realname" value >>realname - "email" value >>email - "new-password" value >>encoded-password - H{ } clone >>profile - - insert-tuple - - next f - ] >>submit ; - -:: ( form ctor next -- action ) - - { { "username" [ v-required ] } } >>get-params - - [ - blank-values - - "username" get ctor call select-tuple - - { - [ username>> "username" set-value ] - [ realname>> "realname" set-value ] - [ email>> "email" set-value ] - [ profile>> "profile" set-value ] - [ capabilities>> words>strings "capabilities" set-value ] - } cleave - ] >>init - - [ form edit-form ] >>display - - [ - blank-values - - form validate-form - - "username" value select-tuple - "realname" value >>realname - "email" value >>email - - { "new-password" "verify-password" } - [ value empty? ] all? [ - same-password-twice - "new-password" value >>encoded-password - ] unless - - "capabilities" value { - { [ dup string? ] [ 1array ] } - { [ dup array? ] [ ] } - } cond strings>words >>capabilities - - update-tuple - - next f - ] >>submit ; - -:: ( ctor next -- action ) - - { { "username" [ ] } } >>post-params - - [ - "username" get - [ select-tuple 1 >>deleted update-tuple ] - [ logout-all-sessions ] - bi - - next f - ] >>submit ; - -TUPLE: user-admin < dispatcher ; - -SYMBOL: can-administer-users? - -can-administer-users? define-capability - -:: ( -- responder ) - [let | ctor [ [ ] ] | - user-admin new-dispatcher - ctor "" add-responder - ctor "$user-admin" "new" add-responder - ctor "$user-admin" "edit" add-responder - ctor "$user-admin" "delete" add-responder - - "admin" admin-template >>template - { can-administer-users? } - ] ; - -: make-admin ( username -- ) - - select-tuple - [ can-administer-users? suffix ] change-capabilities - update-tuple ; diff --git a/extra/http/server/auth/admin/user-list.xml b/extra/http/server/auth/admin/user-list.xml deleted file mode 100644 index 520b7f2512..0000000000 --- a/extra/http/server/auth/admin/user-list.xml +++ /dev/null @@ -1,9 +0,0 @@ - - - - - Users - - - - diff --git a/extra/http/server/auth/admin/user-summary.xml b/extra/http/server/auth/admin/user-summary.xml deleted file mode 100644 index c426e7c072..0000000000 --- a/extra/http/server/auth/admin/user-summary.xml +++ /dev/null @@ -1,9 +0,0 @@ - - - - - - - - - diff --git a/extra/webapps/pastebin/paste-list.xml b/extra/webapps/pastebin/paste-list.xml deleted file mode 100644 index c91aa6fc42..0000000000 --- a/extra/webapps/pastebin/paste-list.xml +++ /dev/null @@ -1,15 +0,0 @@ - - - - - Pastebin - - - - - - - -
Summary:Paste by:Date:
- - diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml new file mode 100644 index 0000000000..b99cf28753 --- /dev/null +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -0,0 +1,31 @@ + + + + + + + + +
+ + Pastes + | New Paste + | Atom Feed + + + + + | Edit Profile + + + | Logout + + + +
+ +

+ + + + diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml index 7ca4c95f8e..46604598ce 100644 --- a/extra/webapps/pastebin/pastebin.xml +++ b/extra/webapps/pastebin/pastebin.xml @@ -2,29 +2,20 @@ - + Pastebin - + + + + -
- Pastes - | New Paste - | Atom Feed - - - - - | Edit Profile - - - | Logout - - - -
- -

- - + + + + + + + +
Summary:Paste by:Date:
 diff --git a/extra/http/server/auth/admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml similarity index 100% rename from extra/http/server/auth/admin/edit-user.xml rename to extra/webapps/user-admin/edit-user.xml diff --git a/extra/http/server/auth/admin/new-user.xml b/extra/webapps/user-admin/new-user.xml similarity index 100% rename from extra/http/server/auth/admin/new-user.xml rename to extra/webapps/user-admin/new-user.xml diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor new file mode 100644 index 0000000000..172ab62c50 --- /dev/null +++ b/extra/webapps/user-admin/user-admin.factor @@ -0,0 +1,160 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences accessors namespaces combinators words +assocs db.tuples arrays splitting strings validators +html.elements +html.components +html.templates.chloe +http.server.boilerplate +http.server.auth.providers +http.server.auth.providers.db +http.server.auth.login +http.server.auth +http.server.sessions +http.server.actions +http.server.crud +http.server ; +IN: webapps.user-admin + +: admin-template ( name -- template ) + "resource:extra/webapps/user-admin/" swap ".xml" 3append ; + +: words>strings ( seq -- seq' ) + [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ; + +: strings>words ( seq -- seq' ) + [ ":" split1 swap lookup ] map ; + +: ( -- action ) + + [ f select-tuples "users" set-value ] >>init + [ "user-list" admin-template ] >>display ; + +: ( -- action ) + + [ + "username" param { + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + [ profile>> "profile" set-value ] + } cleave + + capabilities get "all-capabilities" set-value + ] >>init + + [ "new-user" admin-template ] >>display + + [ + { + { "username" [ v-username ] } + { "realname" [ v-one-line ] } + { "new-password" [ v-password ] } + { "verify-password" [ v-password ] } + { "email" [ [ v-email ] v-optional ] } + { "capabilities" [ ] } + } validate-params + + same-password-twice + + user new "username" value >>username select-tuple + [ user-exists ] when + ] >>validate + + [ + "username" value + "realname" value >>realname + "email" value >>email + "new-password" value >>encoded-password + H{ } clone >>profile + + insert-tuple + + "$user-admin" f + ] >>submit ; + +: ( -- action ) + + [ + { { "username" [ v-username ] } } validate-params + + "username" value select-tuple { + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + [ profile>> "profile" set-value ] + [ capabilities>> words>strings "capabilities" set-value ] + } cleave + + capabilities get "all-capabilities" set-value + ] >>init + + [ "edit-user" admin-template ] >>display + + [ + { + { "username" [ v-username ] } + { "realname" [ v-one-line ] } + { "new-password" [ [ v-password ] v-optional ] } + { "verify-password" [ [ v-password ] v-optional ] } + { "email" [ [ v-email ] v-optional ] } + { "capabilities" [ ] } + } validate-params + + "new-password" "verify-password" + [ value empty? ] both? [ + same-password-twice + ] unless + ] >>validate + + [ + "username" value select-tuple + "realname" value >>realname + "email" value >>email + + "new-password" value empty? [ drop ] [ + "new-password" value >>encoded-password + ] if + + "capabilities" value { + { [ dup string? ] [ 1array ] } + { [ dup array? ] [ ] } + } cond strings>words >>capabilities + + update-tuple + + "$user-admin" f + ] >>submit ; + +: ( -- action ) + + [ + { { "username" [ v-username ] } } validate-params + [ select-tuple 1 >>deleted update-tuple ] + [ logout-all-sessions ] + bi + + "$user-admin" f + ] >>submit ; + +TUPLE: user-admin < dispatcher ; + +SYMBOL: can-administer-users? + +can-administer-users? define-capability + +: ( -- responder ) + user-admin new-dispatcher + "" add-responder + "new" add-responder + "edit" add-responder + "delete" add-responder + + "admin" admin-template >>template + { can-administer-users? } ; + +: make-admin ( username -- ) + + select-tuple + [ can-administer-users? suffix ] change-capabilities + update-tuple ; diff --git a/extra/http/server/auth/admin/admin.xml b/extra/webapps/user-admin/user-admin.xml similarity index 100% rename from extra/http/server/auth/admin/admin.xml rename to extra/webapps/user-admin/user-admin.xml diff --git a/extra/webapps/user-admin/user-list.xml b/extra/webapps/user-admin/user-list.xml new file mode 100644 index 0000000000..6887308754 --- /dev/null +++ b/extra/webapps/user-admin/user-list.xml @@ -0,0 +1,13 @@ + + + + + Users + + + + + + + +