From 6d0d6ac80a6d9ff58cc0a591d329b65163272c1a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 21 Nov 2007 23:56:50 -0600 Subject: [PATCH 01/67] Non-working change in trees--should be followed by other tree patches --- extra/trees/splay/splay.factor | 162 ++++++++------------- extra/trees/trees.factor | 259 +++++++++++++++------------------ 2 files changed, 183 insertions(+), 238 deletions(-) diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 4249bbd564..f83cf15d1f 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -1,59 +1,53 @@ ! Copyright (c) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math combinators assocs parser ; +! See http://factor.sf.net/license.txt for BSD license. +USING: arrays kernel math namespaces sequences assocs parser +prettyprint.backend trees generic ; IN: trees.splay -TUPLE: splay-tree r count ; -INSTANCE: splay-tree assoc - -: ( -- splay-tree ) - 0 { set-splay-tree-count } splay-tree construct ; - - splay-node +TUPLE: splay ; +: ( -- splay-tree ) + splay construct-empty + over set-delegate ; : rotate-right ( node -- node ) - dup splay-node-l - [ splay-node-r swap set-splay-node-l ] 2keep - [ set-splay-node-r ] keep ; + dup node-left + [ node-right swap set-node-left ] 2keep + [ set-node-right ] keep ; : rotate-left ( node -- node ) - dup splay-node-r - [ splay-node-l swap set-splay-node-r ] 2keep - [ set-splay-node-l ] keep ; + dup node-right + [ node-left swap set-node-right ] 2keep + [ set-node-left ] keep ; : link-right ( left right key node -- left right key node ) - swap >r [ swap set-splay-node-l ] 2keep - nip dup splay-node-l r> swap ; + swap >r [ swap set-node-left ] 2keep + nip dup node-left r> swap ; : link-left ( left right key node -- left right key node ) - swap >r rot [ set-splay-node-r ] 2keep - drop dup splay-node-r swapd r> swap ; + swap >r rot [ set-node-right ] 2keep + drop dup node-right swapd r> swap ; : cmp ( key node -- obj node -1/0/1 ) - 2dup splay-node-k <=> ; + 2dup node-key <=> ; : lcmp ( key node -- obj node -1/0/1 ) - 2dup splay-node-l splay-node-k <=> ; + 2dup node-left node-key <=> ; : rcmp ( key node -- obj node -1/0/1 ) - 2dup splay-node-r splay-node-k <=> ; + 2dup node-right node-key <=> ; DEFER: (splay) : splay-left ( left right key node -- left right key node ) - dup splay-node-l [ + dup node-left [ lcmp 0 < [ rotate-right ] when - dup splay-node-l [ link-right (splay) ] when + dup node-left [ link-right (splay) ] when ] when ; : splay-right ( left right key node -- left right key node ) - dup splay-node-r [ + dup node-right [ rcmp 0 > [ rotate-left ] when - dup splay-node-r [ link-left (splay) ] when + dup node-right [ link-left (splay) ] when ] when ; : (splay) ( left right key node -- left right key node ) @@ -61,118 +55,88 @@ DEFER: (splay) [ drop splay-left ] [ 0 > [ splay-right ] when ] if ; : assemble ( head left right node -- root ) - [ splay-node-r swap set-splay-node-l ] keep - [ splay-node-l swap set-splay-node-r ] keep - [ swap splay-node-l swap set-splay-node-r ] 2keep - [ swap splay-node-r swap set-splay-node-l ] keep ; + [ node-right swap set-node-left ] keep + [ node-left swap set-node-right ] keep + [ swap node-left swap set-node-right ] 2keep + [ swap node-right swap set-node-left ] keep ; : splay-at ( key node -- node ) - >r >r T{ splay-node } clone dup dup r> r> + >r >r T{ node } clone dup dup r> r> (splay) nip assemble ; : splay ( key tree -- ) - [ splay-tree-r splay-at ] keep set-splay-tree-r ; + [ tree-root splay-at ] keep set-tree-root ; : splay-split ( key tree -- node node ) - 2dup splay splay-tree-r cmp 0 < [ - nip dup splay-node-l swap f over set-splay-node-l + 2dup splay tree-root cmp 0 < [ + nip dup node-left swap f over set-node-left ] [ - nip dup splay-node-r swap f over set-splay-node-r swap + nip dup node-right swap f over set-node-right swap ] if ; : (get-splay) ( key tree -- node ? ) - 2dup splay splay-tree-r cmp 0 = [ + 2dup splay tree-root cmp 0 = [ nip t ] [ 2drop f f ] if ; : get-largest ( node -- node ) - dup [ dup splay-node-r [ nip get-largest ] when* ] when ; + dup [ dup node-right [ nip get-largest ] when* ] when ; : splay-largest - dup [ dup get-largest splay-node-k swap splay-at ] when ; + dup [ dup get-largest node-key swap splay-at ] when ; : splay-join ( n2 n1 -- node ) splay-largest [ - [ set-splay-node-r ] keep + [ set-node-right ] keep ] [ drop f ] if* ; : (remove-splay) ( key tree -- ) tuck (get-splay) nip [ - dup splay-tree-count 1- over set-splay-tree-count - dup splay-node-r swap splay-node-l splay-join - swap set-splay-tree-r + dup tree-count 1- over set-tree-count + dup node-right swap node-left splay-join + swap set-tree-root ] [ drop ] if* ; : (set-splay) ( value key tree -- ) - 2dup (get-splay) [ 2nip set-splay-node-v ] [ - drop dup splay-tree-count 1+ over set-splay-tree-count + 2dup (get-splay) [ 2nip set-node-value ] [ + drop dup tree-count 1+ over set-tree-count 2dup splay-split rot - >r r> set-splay-tree-r + >r node construct-boa r> set-tree-root ] if ; : new-root ( value key tree -- ) - [ 1 swap set-splay-tree-count ] keep - >r f f r> set-splay-tree-r ; + [ 1 swap set-tree-count ] keep + >r r> set-tree-root ; -: splay-call ( splay-node call -- ) - >r [ splay-node-k ] keep splay-node-v r> call ; inline - -: (splay-tree-traverse) ( splay-node quot -- key value ? ) - { - { [ over not ] [ 2drop f f f ] } - { [ [ - >r splay-node-l r> (splay-tree-traverse) - ] 2keep rot ] - [ 2drop t ] } - { [ >r 2nip r> [ splay-call ] 2keep rot ] - [ drop [ splay-node-k ] keep splay-node-v t ] } - { [ t ] [ >r splay-node-r r> (splay-tree-traverse) ] } - } cond ; inline +M: splay set-at ( value key tree -- ) + dup tree-root [ (set-splay) ] [ new-root ] if ; -PRIVATE> - -M: splay-tree assoc-find ( splay-tree quot -- key value ? ) - #! quot: ( k v -- ? ) - #! Not tail recursive so will fail on large splay trees. - >r splay-tree-r r> (splay-tree-traverse) ; - -M: splay-tree set-at ( value key tree -- ) - dup splay-tree-r [ (set-splay) ] [ new-root ] if ; - -M: splay-tree at* ( key tree -- value ? ) - dup splay-tree-r [ - (get-splay) >r dup [ splay-node-v ] when r> +M: splay at* ( key tree -- value ? ) + dup tree-root [ + (get-splay) >r dup [ node-value ] when r> ] [ 2drop f f ] if ; -M: splay-tree delete-at ( key tree -- ) - dup splay-tree-r [ (remove-splay) ] [ 2drop ] if ; +M: splay delete-at ( key tree -- ) + dup tree-root [ (remove-splay) ] [ 2drop ] if ; -M: splay-tree new-assoc - 2drop ; +M: splay new-assoc + 2drop ; -: >splay-tree ( assoc -- splay-tree ) - T{ splay-tree f f 0 } assoc-clone-like ; +: >splay ( assoc -- splay-tree ) + T{ splay T{ tree f f 0 } } assoc-clone-like ; -: S{ - \ } [ >splay-tree ] parse-literal ; parsing +: SPLAY{ + \ } [ >splay ] parse-literal ; parsing -M: splay-tree assoc-like - drop dup splay-tree? [ >splay-tree ] unless ; +M: splay assoc-like + drop dup splay? [ + dup tree? [ tuck set-delegate ] [ >splay ] if + ] unless ; -M: splay-tree clear-assoc - 0 over set-splay-tree-count - f swap set-splay-tree-r ; - -M: splay-tree assoc-size - splay-tree-count ; - -USE: prettyprint.backend -M: splay-tree pprint-delims drop \ S{ \ } ; -M: splay-tree >pprint-sequence >alist ; -M: splay-tree pprint-narrow? drop t ; +M: splay pprint-delims drop \ SPLAY{ \ } ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 0d49cb54d1..372d9b2501 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -1,17 +1,16 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generic math math.parser sequences arrays io namespaces -namespaces.private random layouts ; +USING: kernel generic math sequences arrays io namespaces +prettyprint.private kernel.private assocs random combinators ; IN: trees -TUPLE: tree root ; - -: ( -- tree ) tree construct-empty ; +TUPLE: tree root count ; +: ( -- tree ) + f 0 tree construct-boa ; TUPLE: node key value left right ; - -: ( value key -- node ) - swap f f node construct-boa ; +: ( key value -- node ) + f f node construct-boa ; SYMBOL: current-side @@ -20,28 +19,26 @@ SYMBOL: current-side : go-left? ( -- ? ) current-side get left = ; -: node-link@ ( -- ? quot quot ) go-left? [ node-left ] [ node-right ] ; inline -: set-node-link@ ( -- ? quot quot ) go-left? [ set-node-left ] [ set-node-right ] ; inline +: node-link@ ( node ? -- node ) + go-left? xor [ node-left ] [ node-right ] if ; +: set-node-link@ ( left parent ? -- ) + go-left? xor [ set-node-left ] [ set-node-right ] if ; -: node-link ( node -- child ) node-link@ if ; -: set-node-link ( child node -- ) set-node-link@ if ; -: node+link ( node -- child ) node-link@ swap if ; -: set-node+link ( child node -- ) set-node-link@ swap if ; +: node-link ( node -- child ) f node-link@ ; +: set-node-link ( child node -- ) f set-node-link@ ; +: node+link ( node -- child ) t node-link@ ; +: set-node+link ( child node -- ) t set-node-link@ ; -: with-side ( side quot -- ) H{ } clone >n swap current-side set call ndrop ; inline +: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline : with-other-side ( quot -- ) current-side get neg swap with-side ; inline : go-left ( quot -- ) left swap with-side ; inline : go-right ( quot -- ) right swap with-side ; inline -GENERIC: create-node ( value key tree -- node ) +: change-root ( tree quot -- ) + swap [ tree-root swap call ] keep set-tree-root ; inline -GENERIC: copy-node-contents ( new old -- ) - -M: node copy-node-contents ( new old -- ) - #! copy old's key and value into new (keeping children and parent) - dup node-key pick set-node-key node-value swap set-node-value ; - -M: tree create-node ( value key tree -- node ) drop ; +: leaf? ( node -- ? ) + dup node-left swap node-right or not ; : key-side ( k1 k2 -- side ) #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2 @@ -56,137 +53,121 @@ M: tree create-node ( value key tree -- node ) drop ; : choose-branch ( key node -- key node-left/right ) 2dup node-key key-side [ node-link ] with-side ; -GENERIC: node-get ( key node -- value ) +: node-at* ( key node -- value ? ) + [ + 2dup node-key key= [ + nip node-value t + ] [ + choose-branch node-at* + ] if + ] [ f f ] if* ; -: tree-get ( key tree -- value ) tree-root node-get ; +M: tree at* ( key tree -- value ? ) + tree-root node-at* ; -M: node node-get ( key node -- value ) - 2dup node-key key= [ - nip node-value +: node-set ( value key node -- node ) + 2dup node-key key-side dup zero? [ + drop nip [ set-node-value ] keep ] [ - choose-branch node-get + [ + [ node-link [ node-set ] [ ] if* ] keep + [ set-node-link ] keep + ] with-side ] if ; -M: f node-get ( key f -- f ) nip ; +M: tree set-at ( value key tree -- ) + [ [ node-set ] [ ] if* ] change-root ; -GENERIC: node-get* ( key node -- value ? ) - -: tree-get* ( key tree -- value ? ) tree-root node-get* ; - -M: node node-get* ( key node -- value ? ) - 2dup node-key key= [ - nip node-value t - ] [ - choose-branch node-get* - ] if ; - -M: f node-get* ( key f -- f f ) nip f ; - -GENERIC: node-get-all ( key node -- seq ) - -: tree-get-all ( key tree -- seq ) tree-root node-get-all ; - -M: f node-get-all ( key f -- V{} ) 2drop V{ } clone ; - -M: node node-get-all ( key node -- seq ) - 2dup node-key key= [ - ! duplicate keys are stored to the right because of choose-branch - 2dup node-right node-get-all >r nip node-value r> tuck push - ] [ - choose-branch node-get-all - ] if ; - -GENERIC: node-insert ( value key node -- node ) ! can add duplicates - -: tree-insert ( value key tree -- ) - [ dup tree-root [ nip node-insert ] [ create-node ] if* ] keep set-tree-root ; - -GENERIC: node-set ( value key node -- node ) - #! note that this only sets the first node with this key. if more than one - #! has been inserted then the others won't be modified. (should they be deleted?) - -: tree-set ( value key tree -- ) - [ dup tree-root [ nip node-set ] [ create-node ] if* ] keep set-tree-root ; - -GENERIC: node-delete ( key node -- node ) - -: tree-delete ( key tree -- ) - [ tree-root node-delete ] keep set-tree-root ; - -GENERIC: node-delete-all ( key node -- node ) - -M: f node-delete-all ( key f -- f ) nip ; - -: tree-delete-all ( key tree -- ) - [ tree-root node-delete-all ] keep set-tree-root ; - -: node-map-link ( node quot -- node ) - over node-link swap call over set-node-link ; - -: node-map ( node quot -- node ) - over [ - tuck [ node-map-link ] go-left over call swap [ node-map-link ] go-right - ] [ - drop - ] if ; - -: tree-map ( tree quot -- ) - #! apply quot to each element of the tree, in order - over tree-root swap node-map swap set-tree-root ; - -: node>node-seq ( node -- seq ) - dup [ - dup node-left node>node-seq over 1array rot node-right node>node-seq 3append - ] when ; - -: tree>node-seq ( tree -- seq ) - tree-root node>node-seq ; - -: tree-keys ( tree -- keys ) - tree>node-seq [ node-key ] map ; - -: tree-values ( tree -- values ) - tree>node-seq [ node-value ] map ; - -: leaf? ( node -- ? ) - dup node-left swap node-right or not ; - -GENERIC: valid-node? ( node -- ? ) - -M: f valid-node? ( f -- t ) not ; - -M: node valid-node? ( node -- ? ) - dup dup node-left [ node-key swap node-key key< ] when* >r - dup dup node-right [ node-key swap node-key key> ] when* r> and swap - dup node-left valid-node? swap node-right valid-node? and and ; +: valid-node? ( node -- ? ) + [ + dup dup node-left [ node-key swap node-key key< ] when* >r + dup dup node-right [ node-key swap node-key key> ] when* r> and swap + dup node-left valid-node? swap node-right valid-node? and and + ] [ t ] if* ; : valid-tree? ( tree -- ? ) tree-root valid-node? ; -DEFER: print-tree +: tree-call ( node call -- ) + >r [ node-key ] keep node-value r> call ; inline + +: find-node ( node quot -- key value ? ) + { + { [ over not ] [ 2drop f f f ] } + { [ [ + >r node-left r> find-node + ] 2keep rot ] + [ 2drop t ] } + { [ >r 2nip r> [ tree-call ] 2keep rot ] + [ drop [ node-key ] keep node-value t ] } + { [ t ] [ >r node-right r> find-node ] } + } cond ; inline -: random-tree ( tree size -- tree ) - [ most-positive-fixnum random pick tree-set ] each ; +M: tree assoc-find ( tree quot -- key value ? ) + >r tree-root r> find-node ; -: increasing-tree ( tree size -- tree ) - [ dup pick tree-set ] each ; +M: tree clear-assoc + 0 over set-tree-count + f swap set-tree-root ; -: decreasing-tree ( tree size -- tree ) - reverse increasing-tree ; +M: tree assoc-size + tree-count ; -GENERIC: print-node ( depth node -- ) +: copy-node-contents ( new old -- ) + dup node-key pick set-node-key node-value swap set-node-value ; -M: f print-node ( depth f -- ) 2drop ; +! Deletion +DEFER: delete-node -M: node print-node ( depth node -- ) - ! not pretty, but ok for debugging - over 1+ over node-right print-node - over [ drop " " write ] each dup node-key number>string print - >r 1+ r> node-left print-node ; +: (prune-extremity) ( parent node -- new-extremity ) + dup node-link [ + rot drop (prune-extremity) + ] [ + tuck delete-node swap set-node-link + ] if* ; -: print-tree ( tree -- ) - tree-root 1 swap print-node ; +: prune-extremity ( node -- new-extremity ) + #! remove and return the leftmost or rightmost child of this node. + #! assumes at least one child + dup node-link (prune-extremity) ; -: stump? ( tree -- ? ) - #! is this tree empty? - tree-root not ; +: replace-with-child ( node -- node ) + dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ; +: replace-with-extremity ( node -- node ) + dup node-link dup node+link [ + ! predecessor/successor is not the immediate child + [ prune-extremity ] with-other-side dupd copy-node-contents + ] [ + ! node-link is the predecessor/successor + drop replace-with-child + ] if ; + +: delete-node-with-two-children ( node -- node ) + #! randomised to minimise tree unbalancing + random-side [ replace-with-extremity ] with-side ; + +: delete-node ( node -- node ) + #! delete this node, returning its replacement + dup node-left [ + dup node-right [ + delete-node-with-two-children + ] [ + node-left ! left but no right + ] if + ] [ + dup node-right [ + node-right ! right but not left + ] [ + drop f ! no children + ] if + ] if ; + +: delete-bst-node ( key node -- node ) + 2dup node-key key-side dup zero? [ + drop nip delete-node + ] [ + [ tuck node-link delete-bst-node over set-node-link ] with-side + ] if ; + +M: tree delete-at + [ delete-bst-node ] change-root ; From c4666c8c2d774582fe5687f379a073decb3edfff Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 29 Nov 2007 19:20:15 -0500 Subject: [PATCH 02/67] xml.data now uses extra/delegate for consultation --- extra/xml/data/data.factor | 19 +++---------------- 1 file changed, 3 insertions(+), 16 deletions(-) diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor index 1850171537..cb7dd3c703 100644 --- a/extra/xml/data/data.factor +++ b/extra/xml/data/data.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences sequences.private assocs arrays ; +USING: kernel sequences sequences.private assocs arrays delegate ; IN: xml.data TUPLE: name space tag url ; @@ -89,24 +89,11 @@ TUPLE: tag attrs children ; tag construct ; ! For convenience, tags follow the assoc protocol too (for attrs) -M: tag at* tag-attrs at* ; -M: tag set-at tag-attrs set-at ; -M: tag new-assoc tag-attrs new-assoc ; -M: tag >alist tag-attrs >alist ; -M: tag delete-at tag-attrs delete-at ; -M: tag clear-assoc tag-attrs clear-assoc ; -M: tag assoc-size tag-attrs assoc-size ; -M: tag assoc-like tag-attrs assoc-like ; - +CONSULT: assoc-protocol tag tag-attrs ; INSTANCE: tag assoc ! They also follow the sequence protocol (for children) -M: tag nth tag-children nth ; -M: tag nth-unsafe tag-children nth-unsafe ; -M: tag set-nth tag-children set-nth ; -M: tag set-nth-unsafe tag-children set-nth-unsafe ; -M: tag length tag-children length ; - +CONSULT: sequence-protocol tag tag-children ; INSTANCE: tag sequence ! tag with children=f is contained From 0c3e6501fe22b0838400edf82cda1fa44a9569e1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 30 Nov 2007 23:22:08 -0500 Subject: [PATCH 03/67] New XML generation sytnax and word in sequences.lib --- extra/delegate/delegate.factor | 2 +- extra/rss/rss.factor | 31 +++++++------- extra/sequences/lib/lib.factor | 4 ++ extra/xml/generator/generator.factor | 61 +++++++++++++++++++++++++++- extra/xml/utilities/utilities.factor | 5 ++- 5 files changed, 84 insertions(+), 19 deletions(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 8dc3e3720e..2f13499867 100644 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -42,7 +42,7 @@ M: tuple-class group-words PROTOCOL: sequence-protocol clone clone-like like new new-resizable nth nth-unsafe - set-nth set-nth-unsafe length immutable set-length lengthen ; + set-nth set-nth-unsafe length set-length lengthen ; PROTOCOL: assoc-protocol at* assoc-size >alist assoc-find set-at diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 8a9be3f9f6..d34a985518 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. IN: rss -USING: xml.utilities kernel assocs +USING: xml.utilities kernel assocs xml.generator strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables ; @@ -74,30 +74,29 @@ C: entry : download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. - http-get rot 200 = [ + http-get-stream rot 200 = [ nip read-feed ] [ 2drop "Error retrieving newsfeed file" throw ] if ; ! Atom generation -: simple-tag, ( content name -- ) - [ , ] tag, ; - : entry, ( entry -- ) - "entry" [ - dup entry-title "title" simple-tag, - "link" over entry-link "href" associate contained*, - dup entry-pub-date "published" simple-tag, - entry-description "content" simple-tag, - ] tag, ; + << entry >> [ + << title >> [ dup entry-title , ] + << link [ dup entry-link ] == href // >> + << published >> [ dup entry-pub-date , ] + << content >> [ entry-description , ] + ] ; : feed>xml ( feed -- xml ) - "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ - dup feed-title "title" simple-tag, - "link" over feed-link "href" associate contained*, - feed-entries [ entry, ] each - ] make-xml* ; + > [ + << title >> [ dup feed-title , ] + << link [ dup feed-link ] == href // >> + feed-entries [ entry, ] each + ] + XML> ; : write-feed ( feed -- xml ) feed>xml write-xml ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 33cfe80fcc..2f98e27467 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -62,3 +62,7 @@ IN: sequences.lib : delete-random ( seq -- value ) [ length random ] keep [ nth ] 2keep delete-nth ; + +: split-around ( seq quot -- before elem after ) + dupd find over [ "Element not found" throw ] unless + >r cut-slice 1 tail r> swap ; inline diff --git a/extra/xml/generator/generator.factor b/extra/xml/generator/generator.factor index d5eb64388c..1d1a6c09d3 100644 --- a/extra/xml/generator/generator.factor +++ b/extra/xml/generator/generator.factor @@ -1,4 +1,7 @@ -USING: namespaces kernel xml.data xml.utilities ; +! Copyright (C) 2006, 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel xml.data xml.utilities assocs splitting +sequences parser quotations sequences.lib ; IN: xml.generator : comment, ( string -- ) , ; @@ -21,3 +24,59 @@ IN: xml.generator (tag,) build-xml ; inline : make-xml ( name quot -- xml ) f swap make-xml* ; inline + +SYMBOL: namespace-table +: with-namespaces ( table quot -- ) + >r H{ } assoc-like namespace-table r> with-variable ; inline + +: parsed-name ( accum -- accum ) + scan ":" split1 [ f ] [ ] if* parsed ; + +: run-combinator ( accum quot1 quot2 -- accum ) + >r [ ] like parsed r> [ parsed ] each ; + +: parse-tag-contents ( accum contained? -- accum ) + [ \ contained*, parsed ] [ + scan-word \ [ = + [ POSTPONE: [ \ tag*, parsed ] + [ "Expected [ missing" throw ] if + ] if ; + +DEFER: >> + +: attributes-parsed ( accum quot -- accum ) + dup empty? [ drop f parsed ] [ + >r \ >r parsed r> parsed + [ H{ } make-assoc r> swap ] [ parsed ] each + ] if ; + +: << + parsed-name [ + \ >> parse-until >quotation + attributes-parsed \ contained? get + ] with-scope parse-tag-contents ; parsing + +: == + \ call parsed parsed-name \ set parsed ; parsing + +: // + \ contained? on ; parsing + +: parse-special ( accum end-token word -- accum ) + >r parse-tokens " " join parsed r> parsed ; + +: " \ comment, parse-special ; parsing + +: " \ directive, parse-special ; parsing + +: " \ instruction, parse-special ; parsing + +: >xml-document ( seq -- xml ) + dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap + [ tag? ] split-around ; + +DEFER: XML> + +: [ >quotation ] parse-literal + { } parsed \ make parsed \ >xml-document parsed ; parsing diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index 303de4295e..1bd7b8f149 100644 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -42,8 +42,11 @@ M: process-missing error. : build-tag ( item name -- tag ) >r 1array r> build-tag* ; +: standard-prolog ( -- prolog ) + T{ prolog f "1.0" "iso-8859-1" f } ; + : build-xml ( tag -- xml ) - T{ prolog f "1.0" "iso-8859-1" f } { } rot { } ; + standard-prolog { } rot { } ; : children>string ( tag -- string ) tag-children From fa5b1edca2aaaefe11017070fdb1e2e4b4001644 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 Dec 2007 16:33:46 -0500 Subject: [PATCH 04/67] XML generator changes --- extra/xml/generator/generator.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/xml/generator/generator.factor b/extra/xml/generator/generator.factor index 1d1a6c09d3..84edc4e551 100644 --- a/extra/xml/generator/generator.factor +++ b/extra/xml/generator/generator.factor @@ -25,10 +25,7 @@ IN: xml.generator : make-xml ( name quot -- xml ) f swap make-xml* ; inline -SYMBOL: namespace-table -: with-namespaces ( table quot -- ) - >r H{ } assoc-like namespace-table r> with-variable ; inline - +! Word-based XML literal syntax : parsed-name ( accum -- accum ) scan ":" split1 [ f ] [ ] if* parsed ; From 58a0dff77c475982b13875d4d7334a45fceb50f9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 19 Dec 2007 12:33:34 -0500 Subject: [PATCH 05/67] XML fixes --- extra/faq/faq.factor | 6 +++--- extra/xml/utilities/utilities.factor | 8 ++++---- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index f10e6481fa..1968a9e5f4 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -8,7 +8,7 @@ IN: faq : find-after ( seq quot -- elem after ) over >r find r> rot 1+ tail ; inline -: tag-named? ( tag name -- ? ) +: tag-named*? ( tag name -- ? ) assure-name swap tag-named? ; ! Questions @@ -16,8 +16,8 @@ TUPLE: q/a question answer ; C: q/a : li>q/a ( li -- q/a ) - [ "br" tag-named? not ] subset - [ "strong" tag-named? ] find-after + [ "br" tag-named*? not ] subset + [ "strong" tag-named*? ] find-after >r tag-children r> ; : q/a>li ( q/a -- li ) diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index a86b1c9214..fe64684f22 100644 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -120,10 +120,10 @@ M: xml xml-inject >r delegate >r xml-inject ; dup tag? [ names-match? ] [ 2drop f ] if ; : tag-named* ( tag name/string -- matching-tag ) - assure-name swap [ dupd tag-named? ] xml-find nip ; + assure-name [ swap tag-named? ] curry xml-find ; : tags-named* ( tag name/string -- tags-seq ) - assure-name swap [ dupd tag-named? ] xml-subset nip ; + assure-name [ swap tag-named? ] curry xml-subset ; : tag-named ( tag name/string -- matching-tag ) ! like get-name-tag but only looks at direct children, @@ -144,7 +144,7 @@ M: xml xml-inject >r delegate >r xml-inject ; >r 1vector r> insert-children ; : tag-with-attr? ( elem attr-value attr-name -- ? ) - rot dup tag? [ at = ] [ drop f ] if ; + rot dup tag? [ at = ] [ 3drop f ] if ; : tag-with-attr ( tag attr-value attr-name -- matching-tag ) assure-name [ tag-with-attr? ] 2curry find nip ; @@ -153,7 +153,7 @@ M: xml xml-inject >r delegate >r xml-inject ; assure-name [ tag-with-attr? ] 2curry subset ; : tag-with-attr* ( tag attr-value attr-name -- matching-tag ) - assure-name [ tag-with-attr? ] 2curry xml-find nip ; + assure-name [ tag-with-attr? ] 2curry xml-find ; : tags-with-attr* ( tag attr-value attr-name -- tags-seq ) assure-name [ tag-with-attr? ] 2curry xml-subset ; From ded88583efc35b2604e4554c6e9f6cedcedae16c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Dec 2007 00:06:36 -0600 Subject: [PATCH 06/67] fixed heap-push-all --- core/heaps/heaps.factor | 3 +-- extra/assoc-heaps/assoc-heaps-tests.factor | 9 +++++++++ extra/assoc-heaps/assoc-heaps.factor | 3 --- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index f01b436e90..cd00dc0db3 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -6,7 +6,6 @@ IN: heaps MIXIN: priority-queue GENERIC: heap-push ( value key heap -- ) -GENERIC: heap-push-all ( assoc heap -- ) GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-pop* ( heap -- ) GENERIC: heap-pop ( heap -- value key ) @@ -107,7 +106,7 @@ M: priority-queue heap-push ( value key heap -- ) [ heap-data ] keep up-heap ; -M: priority-queue heap-push-all ( assoc heap -- ) +: heap-push-all ( assoc heap -- ) [ swapd heap-push ] curry assoc-each ; M: priority-queue heap-peek ( heap -- value key ) diff --git a/extra/assoc-heaps/assoc-heaps-tests.factor b/extra/assoc-heaps/assoc-heaps-tests.factor index 656e7fc15c..24a7730847 100644 --- a/extra/assoc-heaps/assoc-heaps-tests.factor +++ b/extra/assoc-heaps/assoc-heaps-tests.factor @@ -44,3 +44,12 @@ T{ T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } } } heap-pop ] unit-test + +[ +T{ + assoc-heap + f + H{ { 1 2 } { 3 4 } } + T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } } +} +] [ H{ { 1 2 } { 3 4 } } H{ } clone [ heap-push-all ] keep ] unit-test diff --git a/extra/assoc-heaps/assoc-heaps.factor b/extra/assoc-heaps/assoc-heaps.factor index 0c44950923..552845b00e 100644 --- a/extra/assoc-heaps/assoc-heaps.factor +++ b/extra/assoc-heaps/assoc-heaps.factor @@ -40,9 +40,6 @@ M: assoc-heap heap-peek ( assoc-heap -- value key ) M: assoc-heap heap-push ( value key assoc-heap -- ) set-at ; -M: assoc-heap heap-push-all ( assoc assoc-heap -- ) - swap [ rot set-at ] curry* each ; - M: assoc-heap heap-pop ( assoc-heap -- value key ) dup assoc-heap-heap heap-pop swap rot dupd assoc-heap-assoc delete-at ; From f0903db414437dfdcecd7c13c2d1c729c31f9ff3 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 22 Dec 2007 01:25:01 +0100 Subject: [PATCH 07/67] Remove obsolete performance comment on project Euler problem 10 --- extra/project-euler/010/010.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor index 7518eb2f6f..055e902776 100644 --- a/extra/project-euler/010/010.factor +++ b/extra/project-euler/010/010.factor @@ -22,9 +22,6 @@ IN: project-euler.010 : euler010 ( -- answer ) 0 1000000 lerato [ + ] leach ; -! TODO: solution is still too slow for 1000000, probably due to seq-diff -! calling member? for each number that we want to remove - ! [ euler010 ] time ! 765 ms run / 7 ms GC time From 621790aa7fe583e2bbad419b8f64ac7e23347ec9 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 22 Dec 2007 01:24:32 +0100 Subject: [PATCH 08/67] Factor solution to project Euler problem 18 --- extra/project-euler/018/018.factor | 90 ++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) create mode 100644 extra/project-euler/018/018.factor diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor new file mode 100644 index 0000000000..bc3bf56c86 --- /dev/null +++ b/extra/project-euler/018/018.factor @@ -0,0 +1,90 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences ; +IN: project-euler.018 + +! http://projecteuler.net/index.php?section=problems&id=18 + +! DESCRIPTION +! ----------- + +! By starting at the top of the triangle below and moving to adjacent +! numbers on the row below, the maximum total from top to bottom is +! 23. + +! 3 +! 7 5 +! 2 4 6 +! 8 5 9 3 + +! That is, 3 + 7 + 4 + 9 = 23. + +! Find the maximum total from top to bottom of the triangle below: + +! 75 +! 95 64 +! 17 47 82 +! 18 35 87 10 +! 20 04 82 47 65 +! 19 01 23 75 03 34 +! 88 02 77 73 07 63 67 +! 99 65 04 28 06 16 70 92 +! 41 41 26 56 83 40 80 70 33 +! 41 48 72 33 47 32 37 16 94 29 +! 53 71 44 65 25 43 91 52 97 51 14 +! 70 11 33 28 77 73 17 78 39 68 17 57 +! 91 71 52 38 17 14 91 43 58 50 27 29 48 +! 63 66 04 68 89 53 67 30 73 16 69 87 40 31 +! 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 + +! NOTE: As there are only 16384 routes, it is possible to solve this +! problem by trying every route. However, Problem 67, is the same +! challenge with a triangle containing one-hundred rows; it cannot be +! solved by brute force, and requires a clever method! ;o) + +! SOLUTION +! -------- + +! Propagate from bottom to top the longest cumulative path. This is very +! efficient and will be reused in problem 67. + + + +! Propagate one row into the upper one +: propagate ( bottom top -- newtop ) + [ over 1 tail rot first2 max rot + ] map nip ; + +! Not strictly needed, but it is nice to be able to dump the pyramid after +! the propagation +: propagate-all ( pyramid -- newpyramid ) + reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ; + +: euler018 ( -- best ) + pyramid propagate-all first first ; + +! [ euler018 ] 100 ave-time +! 0 ms run / 0 ms GC time + +MAIN: euler018 From 8d268ba8587dc8bf7b52782af16ba116fff8baf8 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 22 Dec 2007 01:45:20 +0100 Subject: [PATCH 09/67] Factor solution to project Euler problem 67 --- extra/project-euler/067/067.factor | 45 ++++++++++++ extra/project-euler/067/triangle.txt | 100 +++++++++++++++++++++++++++ 2 files changed, 145 insertions(+) create mode 100644 extra/project-euler/067/067.factor create mode 100644 extra/project-euler/067/triangle.txt diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor new file mode 100644 index 0000000000..4a8188da3a --- /dev/null +++ b/extra/project-euler/067/067.factor @@ -0,0 +1,45 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.files math.parser project-euler.018 sequences splitting ; +IN: project-euler.067 + +! http://projecteuler.net/index.php?section=problems&id=67 + +! DESCRIPTION +! ----------- + +! By starting at the top of the triangle below and moving to adjacent +! numbers on the row below, the maximum total from top to bottom is +! 23. + +! 3 +! 7 5 +! 2 4 6 +! 8 5 9 3 + +! That is, 3 + 7 + 4 + 9 = 23. + +! Find the maximum total from top to bottom in triangle.txt, a 15K +! text file containing a triangle with one-hundred rows. + +! SOLUTION +! -------- + +! Propagate from bottom to top the longest cumulative path as is done in +! problem 18. + + + lines [ " " split [ string>number ] map ] map ; + +PRIVATE> + +: euler067 ( -- best ) + pyramid propagate-all first first ; + +! [ euler067 ] 100 ave-time +! 18 ms run / 0 ms GC time + +MAIN: euler067 diff --git a/extra/project-euler/067/triangle.txt b/extra/project-euler/067/triangle.txt new file mode 100644 index 0000000000..00f98e3eba --- /dev/null +++ b/extra/project-euler/067/triangle.txt @@ -0,0 +1,100 @@ +59 +73 41 +52 40 09 +26 53 06 34 +10 51 87 86 81 +61 95 66 57 25 68 +90 81 80 38 92 67 73 +30 28 51 76 81 18 75 44 +84 14 95 87 62 81 17 78 58 +21 46 71 58 02 79 62 39 31 09 +56 34 35 53 78 31 81 18 90 93 15 +78 53 04 21 84 93 32 13 97 11 37 51 +45 03 81 79 05 18 78 86 13 30 63 99 95 +39 87 96 28 03 38 42 17 82 87 58 07 22 57 +06 17 51 17 07 93 09 07 75 97 95 78 87 08 53 +67 66 59 60 88 99 94 65 55 77 55 34 27 53 78 28 +76 40 41 04 87 16 09 42 75 69 23 97 30 60 10 79 87 +12 10 44 26 21 36 32 84 98 60 13 12 36 16 63 31 91 35 +70 39 06 05 55 27 38 48 28 22 34 35 62 62 15 14 94 89 86 +66 56 68 84 96 21 34 34 34 81 62 40 65 54 62 05 98 03 02 60 +38 89 46 37 99 54 34 53 36 14 70 26 02 90 45 13 31 61 83 73 47 +36 10 63 96 60 49 41 05 37 42 14 58 84 93 96 17 09 43 05 43 06 59 +66 57 87 57 61 28 37 51 84 73 79 15 39 95 88 87 43 39 11 86 77 74 18 +54 42 05 79 30 49 99 73 46 37 50 02 45 09 54 52 27 95 27 65 19 45 26 45 +71 39 17 78 76 29 52 90 18 99 78 19 35 62 71 19 23 65 93 85 49 33 75 09 02 +33 24 47 61 60 55 32 88 57 55 91 54 46 57 07 77 98 52 80 99 24 25 46 78 79 05 +92 09 13 55 10 67 26 78 76 82 63 49 51 31 24 68 05 57 07 54 69 21 67 43 17 63 12 +24 59 06 08 98 74 66 26 61 60 13 03 09 09 24 30 71 08 88 70 72 70 29 90 11 82 41 34 +66 82 67 04 36 60 92 77 91 85 62 49 59 61 30 90 29 94 26 41 89 04 53 22 83 41 09 74 90 +48 28 26 37 28 52 77 26 51 32 18 98 79 36 62 13 17 08 19 54 89 29 73 68 42 14 08 16 70 37 +37 60 69 70 72 71 09 59 13 60 38 13 57 36 09 30 43 89 30 39 15 02 44 73 05 73 26 63 56 86 12 +55 55 85 50 62 99 84 77 28 85 03 21 27 22 19 26 82 69 54 04 13 07 85 14 01 15 70 59 89 95 10 19 +04 09 31 92 91 38 92 86 98 75 21 05 64 42 62 84 36 20 73 42 21 23 22 51 51 79 25 45 85 53 03 43 22 +75 63 02 49 14 12 89 14 60 78 92 16 44 82 38 30 72 11 46 52 90 27 08 65 78 03 85 41 57 79 39 52 33 48 +78 27 56 56 39 13 19 43 86 72 58 95 39 07 04 34 21 98 39 15 39 84 89 69 84 46 37 57 59 35 59 50 26 15 93 +42 89 36 27 78 91 24 11 17 41 05 94 07 69 51 96 03 96 47 90 90 45 91 20 50 56 10 32 36 49 04 53 85 92 25 65 +52 09 61 30 61 97 66 21 96 92 98 90 06 34 96 60 32 69 68 33 75 84 18 31 71 50 84 63 03 03 19 11 28 42 75 45 45 +61 31 61 68 96 34 49 39 05 71 76 59 62 67 06 47 96 99 34 21 32 47 52 07 71 60 42 72 94 56 82 83 84 40 94 87 82 46 +01 20 60 14 17 38 26 78 66 81 45 95 18 51 98 81 48 16 53 88 37 52 69 95 72 93 22 34 98 20 54 27 73 61 56 63 60 34 63 +93 42 94 83 47 61 27 51 79 79 45 01 44 73 31 70 83 42 88 25 53 51 30 15 65 94 80 44 61 84 12 77 02 62 02 65 94 42 14 94 +32 73 09 67 68 29 74 98 10 19 85 48 38 31 85 67 53 93 93 77 47 67 39 72 94 53 18 43 77 40 78 32 29 59 24 06 02 83 50 60 66 +32 01 44 30 16 51 15 81 98 15 10 62 86 79 50 62 45 60 70 38 31 85 65 61 64 06 69 84 14 22 56 43 09 48 66 69 83 91 60 40 36 61 +92 48 22 99 15 95 64 43 01 16 94 02 99 19 17 69 11 58 97 56 89 31 77 45 67 96 12 73 08 20 36 47 81 44 50 64 68 85 40 81 85 52 09 +91 35 92 45 32 84 62 15 19 64 21 66 06 01 52 80 62 59 12 25 88 28 91 50 40 16 22 99 92 79 87 51 21 77 74 77 07 42 38 42 74 83 02 05 +46 19 77 66 24 18 05 32 02 84 31 99 92 58 96 72 91 36 62 99 55 29 53 42 12 37 26 58 89 50 66 19 82 75 12 48 24 87 91 85 02 07 03 76 86 +99 98 84 93 07 17 33 61 92 20 66 60 24 66 40 30 67 05 37 29 24 96 03 27 70 62 13 04 45 47 59 88 43 20 66 15 46 92 30 04 71 66 78 70 53 99 +67 60 38 06 88 04 17 72 10 99 71 07 42 25 54 05 26 64 91 50 45 71 06 30 67 48 69 82 08 56 80 67 18 46 66 63 01 20 08 80 47 07 91 16 03 79 87 +18 54 78 49 80 48 77 40 68 23 60 88 58 80 33 57 11 69 55 53 64 02 94 49 60 92 16 35 81 21 82 96 25 24 96 18 02 05 49 03 50 77 06 32 84 27 18 38 +68 01 50 04 03 21 42 94 53 24 89 05 92 26 52 36 68 11 85 01 04 42 02 45 15 06 50 04 53 73 25 74 81 88 98 21 67 84 79 97 99 20 95 04 40 46 02 58 87 +94 10 02 78 88 52 21 03 88 60 06 53 49 71 20 91 12 65 07 49 21 22 11 41 58 99 36 16 09 48 17 24 52 36 23 15 72 16 84 56 02 99 43 76 81 71 29 39 49 17 +64 39 59 84 86 16 17 66 03 09 43 06 64 18 63 29 68 06 23 07 87 14 26 35 17 12 98 41 53 64 78 18 98 27 28 84 80 67 75 62 10 11 76 90 54 10 05 54 41 39 66 +43 83 18 37 32 31 52 29 95 47 08 76 35 11 04 53 35 43 34 10 52 57 12 36 20 39 40 55 78 44 07 31 38 26 08 15 56 88 86 01 52 62 10 24 32 05 60 65 53 28 57 99 +03 50 03 52 07 73 49 92 66 80 01 46 08 67 25 36 73 93 07 42 25 53 13 96 76 83 87 90 54 89 78 22 78 91 73 51 69 09 79 94 83 53 09 40 69 62 10 79 49 47 03 81 30 +71 54 73 33 51 76 59 54 79 37 56 45 84 17 62 21 98 69 41 95 65 24 39 37 62 03 24 48 54 64 46 82 71 78 33 67 09 16 96 68 52 74 79 68 32 21 13 78 96 60 09 69 20 36 +73 26 21 44 46 38 17 83 65 98 07 23 52 46 61 97 33 13 60 31 70 15 36 77 31 58 56 93 75 68 21 36 69 53 90 75 25 82 39 50 65 94 29 30 11 33 11 13 96 02 56 47 07 49 02 +76 46 73 30 10 20 60 70 14 56 34 26 37 39 48 24 55 76 84 91 39 86 95 61 50 14 53 93 64 67 37 31 10 84 42 70 48 20 10 72 60 61 84 79 69 65 99 73 89 25 85 48 92 56 97 16 +03 14 80 27 22 30 44 27 67 75 79 32 51 54 81 29 65 14 19 04 13 82 04 91 43 40 12 52 29 99 07 76 60 25 01 07 61 71 37 92 40 47 99 66 57 01 43 44 22 40 53 53 09 69 26 81 07 +49 80 56 90 93 87 47 13 75 28 87 23 72 79 32 18 27 20 28 10 37 59 21 18 70 04 79 96 03 31 45 71 81 06 14 18 17 05 31 50 92 79 23 47 09 39 47 91 43 54 69 47 42 95 62 46 32 85 +37 18 62 85 87 28 64 05 77 51 47 26 30 65 05 70 65 75 59 80 42 52 25 20 44 10 92 17 71 95 52 14 77 13 24 55 11 65 26 91 01 30 63 15 49 48 41 17 67 47 03 68 20 90 98 32 04 40 68 +90 51 58 60 06 55 23 68 05 19 76 94 82 36 96 43 38 90 87 28 33 83 05 17 70 83 96 93 06 04 78 47 80 06 23 84 75 23 87 72 99 14 50 98 92 38 90 64 61 58 76 94 36 66 87 80 51 35 61 38 +57 95 64 06 53 36 82 51 40 33 47 14 07 98 78 65 39 58 53 06 50 53 04 69 40 68 36 69 75 78 75 60 03 32 39 24 74 47 26 90 13 40 44 71 90 76 51 24 36 50 25 45 70 80 61 80 61 43 90 64 11 +18 29 86 56 68 42 79 10 42 44 30 12 96 18 23 18 52 59 02 99 67 46 60 86 43 38 55 17 44 93 42 21 55 14 47 34 55 16 49 24 23 29 96 51 55 10 46 53 27 92 27 46 63 57 30 65 43 27 21 20 24 83 +81 72 93 19 69 52 48 01 13 83 92 69 20 48 69 59 20 62 05 42 28 89 90 99 32 72 84 17 08 87 36 03 60 31 36 36 81 26 97 36 48 54 56 56 27 16 91 08 23 11 87 99 33 47 02 14 44 73 70 99 43 35 33 +90 56 61 86 56 12 70 59 63 32 01 15 81 47 71 76 95 32 65 80 54 70 34 51 40 45 33 04 64 55 78 68 88 47 31 47 68 87 03 84 23 44 89 72 35 08 31 76 63 26 90 85 96 67 65 91 19 14 17 86 04 71 32 95 +37 13 04 22 64 37 37 28 56 62 86 33 07 37 10 44 52 82 52 06 19 52 57 75 90 26 91 24 06 21 14 67 76 30 46 14 35 89 89 41 03 64 56 97 87 63 22 34 03 79 17 45 11 53 25 56 96 61 23 18 63 31 37 37 47 +77 23 26 70 72 76 77 04 28 64 71 69 14 85 96 54 95 48 06 62 99 83 86 77 97 75 71 66 30 19 57 90 33 01 60 61 14 12 90 99 32 77 56 41 18 14 87 49 10 14 90 64 18 50 21 74 14 16 88 05 45 73 82 47 74 44 +22 97 41 13 34 31 54 61 56 94 03 24 59 27 98 77 04 09 37 40 12 26 87 09 71 70 07 18 64 57 80 21 12 71 83 94 60 39 73 79 73 19 97 32 64 29 41 07 48 84 85 67 12 74 95 20 24 52 41 67 56 61 29 93 35 72 69 +72 23 63 66 01 11 07 30 52 56 95 16 65 26 83 90 50 74 60 18 16 48 43 77 37 11 99 98 30 94 91 26 62 73 45 12 87 73 47 27 01 88 66 99 21 41 95 80 02 53 23 32 61 48 32 43 43 83 14 66 95 91 19 81 80 67 25 88 +08 62 32 18 92 14 83 71 37 96 11 83 39 99 05 16 23 27 10 67 02 25 44 11 55 31 46 64 41 56 44 74 26 81 51 31 45 85 87 09 81 95 22 28 76 69 46 48 64 87 67 76 27 89 31 11 74 16 62 03 60 94 42 47 09 34 94 93 72 +56 18 90 18 42 17 42 32 14 86 06 53 33 95 99 35 29 15 44 20 49 59 25 54 34 59 84 21 23 54 35 90 78 16 93 13 37 88 54 19 86 67 68 55 66 84 65 42 98 37 87 56 33 28 58 38 28 38 66 27 52 21 81 15 08 22 97 32 85 27 +91 53 40 28 13 34 91 25 01 63 50 37 22 49 71 58 32 28 30 18 68 94 23 83 63 62 94 76 80 41 90 22 82 52 29 12 18 56 10 08 35 14 37 57 23 65 67 40 72 39 93 39 70 89 40 34 07 46 94 22 20 05 53 64 56 30 05 56 61 88 27 +23 95 11 12 37 69 68 24 66 10 87 70 43 50 75 07 62 41 83 58 95 93 89 79 45 39 02 22 05 22 95 43 62 11 68 29 17 40 26 44 25 71 87 16 70 85 19 25 59 94 90 41 41 80 61 70 55 60 84 33 95 76 42 63 15 09 03 40 38 12 03 32 +09 84 56 80 61 55 85 97 16 94 82 94 98 57 84 30 84 48 93 90 71 05 95 90 73 17 30 98 40 64 65 89 07 79 09 19 56 36 42 30 23 69 73 72 07 05 27 61 24 31 43 48 71 84 21 28 26 65 65 59 65 74 77 20 10 81 61 84 95 08 52 23 70 +47 81 28 09 98 51 67 64 35 51 59 36 92 82 77 65 80 24 72 53 22 07 27 10 21 28 30 22 48 82 80 48 56 20 14 43 18 25 50 95 90 31 77 08 09 48 44 80 90 22 93 45 82 17 13 96 25 26 08 73 34 99 06 49 24 06 83 51 40 14 15 10 25 01 +54 25 10 81 30 64 24 74 75 80 36 75 82 60 22 69 72 91 45 67 03 62 79 54 89 74 44 83 64 96 66 73 44 30 74 50 37 05 09 97 70 01 60 46 37 91 39 75 75 18 58 52 72 78 51 81 86 52 08 97 01 46 43 66 98 62 81 18 70 93 73 08 32 46 34 +96 80 82 07 59 71 92 53 19 20 88 66 03 26 26 10 24 27 50 82 94 73 63 08 51 33 22 45 19 13 58 33 90 15 22 50 36 13 55 06 35 47 82 52 33 61 36 27 28 46 98 14 73 20 73 32 16 26 80 53 47 66 76 38 94 45 02 01 22 52 47 96 64 58 52 39 +88 46 23 39 74 63 81 64 20 90 33 33 76 55 58 26 10 46 42 26 74 74 12 83 32 43 09 02 73 55 86 54 85 34 28 23 29 79 91 62 47 41 82 87 99 22 48 90 20 05 96 75 95 04 43 28 81 39 81 01 28 42 78 25 39 77 90 57 58 98 17 36 73 22 63 74 51 +29 39 74 94 95 78 64 24 38 86 63 87 93 06 70 92 22 16 80 64 29 52 20 27 23 50 14 13 87 15 72 96 81 22 08 49 72 30 70 24 79 31 16 64 59 21 89 34 96 91 48 76 43 53 88 01 57 80 23 81 90 79 58 01 80 87 17 99 86 90 72 63 32 69 14 28 88 69 +37 17 71 95 56 93 71 35 43 45 04 98 92 94 84 96 11 30 31 27 31 60 92 03 48 05 98 91 86 94 35 90 90 08 48 19 33 28 68 37 59 26 65 96 50 68 22 07 09 49 34 31 77 49 43 06 75 17 81 87 61 79 52 26 27 72 29 50 07 98 86 01 17 10 46 64 24 18 56 +51 30 25 94 88 85 79 91 40 33 63 84 49 67 98 92 15 26 75 19 82 05 18 78 65 93 61 48 91 43 59 41 70 51 22 15 92 81 67 91 46 98 11 11 65 31 66 10 98 65 83 21 05 56 05 98 73 67 46 74 69 34 08 30 05 52 07 98 32 95 30 94 65 50 24 63 28 81 99 57 +19 23 61 36 09 89 71 98 65 17 30 29 89 26 79 74 94 11 44 48 97 54 81 55 39 66 69 45 28 47 13 86 15 76 74 70 84 32 36 33 79 20 78 14 41 47 89 28 81 05 99 66 81 86 38 26 06 25 13 60 54 55 23 53 27 05 89 25 23 11 13 54 59 54 56 34 16 24 53 44 06 +13 40 57 72 21 15 60 08 04 19 11 98 34 45 09 97 86 71 03 15 56 19 15 44 97 31 90 04 87 87 76 08 12 30 24 62 84 28 12 85 82 53 99 52 13 94 06 65 97 86 09 50 94 68 69 74 30 67 87 94 63 07 78 27 80 36 69 41 06 92 32 78 37 82 30 05 18 87 99 72 19 99 +44 20 55 77 69 91 27 31 28 81 80 27 02 07 97 23 95 98 12 25 75 29 47 71 07 47 78 39 41 59 27 76 13 15 66 61 68 35 69 86 16 53 67 63 99 85 41 56 08 28 33 40 94 76 90 85 31 70 24 65 84 65 99 82 19 25 54 37 21 46 33 02 52 99 51 33 26 04 87 02 08 18 96 +54 42 61 45 91 06 64 79 80 82 32 16 83 63 42 49 19 78 65 97 40 42 14 61 49 34 04 18 25 98 59 30 82 72 26 88 54 36 21 75 03 88 99 53 46 51 55 78 22 94 34 40 68 87 84 25 30 76 25 08 92 84 42 61 40 38 09 99 40 23 29 39 46 55 10 90 35 84 56 70 63 23 91 39 +52 92 03 71 89 07 09 37 68 66 58 20 44 92 51 56 13 71 79 99 26 37 02 06 16 67 36 52 58 16 79 73 56 60 59 27 44 77 94 82 20 50 98 33 09 87 94 37 40 83 64 83 58 85 17 76 53 02 83 52 22 27 39 20 48 92 45 21 09 42 24 23 12 37 52 28 50 78 79 20 86 62 73 20 59 +54 96 80 15 91 90 99 70 10 09 58 90 93 50 81 99 54 38 36 10 30 11 35 84 16 45 82 18 11 97 36 43 96 79 97 65 40 48 23 19 17 31 64 52 65 65 37 32 65 76 99 79 34 65 79 27 55 33 03 01 33 27 61 28 66 08 04 70 49 46 48 83 01 45 19 96 13 81 14 21 31 79 93 85 50 05 +92 92 48 84 59 98 31 53 23 27 15 22 79 95 24 76 05 79 16 93 97 89 38 89 42 83 02 88 94 95 82 21 01 97 48 39 31 78 09 65 50 56 97 61 01 07 65 27 21 23 14 15 80 97 44 78 49 35 33 45 81 74 34 05 31 57 09 38 94 07 69 54 69 32 65 68 46 68 78 90 24 28 49 51 45 86 35 +41 63 89 76 87 31 86 09 46 14 87 82 22 29 47 16 13 10 70 72 82 95 48 64 58 43 13 75 42 69 21 12 67 13 64 85 58 23 98 09 37 76 05 22 31 12 66 50 29 99 86 72 45 25 10 28 19 06 90 43 29 31 67 79 46 25 74 14 97 35 76 37 65 46 23 82 06 22 30 76 93 66 94 17 96 13 20 72 +63 40 78 08 52 09 90 41 70 28 36 14 46 44 85 96 24 52 58 15 87 37 05 98 99 39 13 61 76 38 44 99 83 74 90 22 53 80 56 98 30 51 63 39 44 30 91 91 04 22 27 73 17 35 53 18 35 45 54 56 27 78 48 13 69 36 44 38 71 25 30 56 15 22 73 43 32 69 59 25 93 83 45 11 34 94 44 39 92 +12 36 56 88 13 96 16 12 55 54 11 47 19 78 17 17 68 81 77 51 42 55 99 85 66 27 81 79 93 42 65 61 69 74 14 01 18 56 12 01 58 37 91 22 42 66 83 25 19 04 96 41 25 45 18 69 96 88 36 93 10 12 98 32 44 83 83 04 72 91 04 27 73 07 34 37 71 60 59 31 01 54 54 44 96 93 83 36 04 45 +30 18 22 20 42 96 65 79 17 41 55 69 94 81 29 80 91 31 85 25 47 26 43 49 02 99 34 67 99 76 16 14 15 93 08 32 99 44 61 77 67 50 43 55 87 55 53 72 17 46 62 25 50 99 73 05 93 48 17 31 70 80 59 09 44 59 45 13 74 66 58 94 87 73 16 14 85 38 74 99 64 23 79 28 71 42 20 37 82 31 23 +51 96 39 65 46 71 56 13 29 68 53 86 45 33 51 49 12 91 21 21 76 85 02 17 98 15 46 12 60 21 88 30 92 83 44 59 42 50 27 88 46 86 94 73 45 54 23 24 14 10 94 21 20 34 23 51 04 83 99 75 90 63 60 16 22 33 83 70 11 32 10 50 29 30 83 46 11 05 31 17 86 42 49 01 44 63 28 60 07 78 95 40 +44 61 89 59 04 49 51 27 69 71 46 76 44 04 09 34 56 39 15 06 94 91 75 90 65 27 56 23 74 06 23 33 36 69 14 39 05 34 35 57 33 22 76 46 56 10 61 65 98 09 16 69 04 62 65 18 99 76 49 18 72 66 73 83 82 40 76 31 89 91 27 88 17 35 41 35 32 51 32 67 52 68 74 85 80 57 07 11 62 66 47 22 67 +65 37 19 97 26 17 16 24 24 17 50 37 64 82 24 36 32 11 68 34 69 31 32 89 79 93 96 68 49 90 14 23 04 04 67 99 81 74 70 74 36 96 68 09 64 39 88 35 54 89 96 58 66 27 88 97 32 14 06 35 78 20 71 06 85 66 57 02 58 91 72 05 29 56 73 48 86 52 09 93 22 57 79 42 12 01 31 68 17 59 63 76 07 77 +73 81 14 13 17 20 11 09 01 83 08 85 91 70 84 63 62 77 37 07 47 01 59 95 39 69 39 21 99 09 87 02 97 16 92 36 74 71 90 66 33 73 73 75 52 91 11 12 26 53 05 26 26 48 61 50 90 65 01 87 42 47 74 35 22 73 24 26 56 70 52 05 48 41 31 18 83 27 21 39 80 85 26 08 44 02 71 07 63 22 05 52 19 08 20 +17 25 21 11 72 93 33 49 64 23 53 82 03 13 91 65 85 02 40 05 42 31 77 42 05 36 06 54 04 58 07 76 87 83 25 57 66 12 74 33 85 37 74 32 20 69 03 97 91 68 82 44 19 14 89 28 85 85 80 53 34 87 58 98 88 78 48 65 98 40 11 57 10 67 70 81 60 79 74 72 97 59 79 47 30 20 54 80 89 91 14 05 33 36 79 39 +60 85 59 39 60 07 57 76 77 92 06 35 15 72 23 41 45 52 95 18 64 79 86 53 56 31 69 11 91 31 84 50 44 82 22 81 41 40 30 42 30 91 48 94 74 76 64 58 74 25 96 57 14 19 03 99 28 83 15 75 99 01 89 85 79 50 03 95 32 67 44 08 07 41 62 64 29 20 14 76 26 55 48 71 69 66 19 72 44 25 14 01 48 74 12 98 07 +64 66 84 24 18 16 27 48 20 14 47 69 30 86 48 40 23 16 61 21 51 50 26 47 35 33 91 28 78 64 43 68 04 79 51 08 19 60 52 95 06 68 46 86 35 97 27 58 04 65 30 58 99 12 12 75 91 39 50 31 42 64 70 04 46 07 98 73 98 93 37 89 77 91 64 71 64 65 66 21 78 62 81 74 42 20 83 70 73 95 78 45 92 27 34 53 71 15 +30 11 85 31 34 71 13 48 05 14 44 03 19 67 23 73 19 57 06 90 94 72 57 69 81 62 59 68 88 57 55 69 49 13 07 87 97 80 89 05 71 05 05 26 38 40 16 62 45 99 18 38 98 24 21 26 62 74 69 04 85 57 77 35 58 67 91 79 79 57 86 28 66 34 72 51 76 78 36 95 63 90 08 78 47 63 45 31 22 70 52 48 79 94 15 77 61 67 68 +23 33 44 81 80 92 93 75 94 88 23 61 39 76 22 03 28 94 32 06 49 65 41 34 18 23 08 47 62 60 03 63 33 13 80 52 31 54 73 43 70 26 16 69 57 87 83 31 03 93 70 81 47 95 77 44 29 68 39 51 56 59 63 07 25 70 07 77 43 53 64 03 94 42 95 39 18 01 66 21 16 97 20 50 90 16 70 10 95 69 29 06 25 61 41 26 15 59 63 35 From 13d5ce70b0caf0fbd8025b60a228d1347f6f18f5 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sun, 23 Dec 2007 13:45:46 +0100 Subject: [PATCH 10/67] Factor solution to project Euler problem 19 --- extra/project-euler/019/019.factor | 41 ++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 extra/project-euler/019/019.factor diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor new file mode 100644 index 0000000000..26ea74e689 --- /dev/null +++ b/extra/project-euler/019/019.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar combinators combinators.lib kernel math.ranges sequences ; +IN: project-euler.019 + +! http://projecteuler.net/index.php?section=problems&id=19 + +! DESCRIPTION +! ----------- + +! You are given the following information, but you may prefer to do some +! research for yourself. + +! * 1 Jan 1900 was a Monday. +! * Thirty days has September, +! April, June and November. +! All the rest have thirty-one, +! Saving February alone, +! Which has twenty-eight, rain or shine. +! And on leap years, twenty-nine. +! * A leap year occurs on any year evenly divisible by 4, but not +! on a century unless it is divisible by 400. + +! How many Sundays fell on the first of the month during the twentieth +! century (1 Jan 1901 to 31 Dec 2000)? + +! SOLUTION +! -------- + +! Use Zeller congruence, which is implemented in the "calendar" module +! already, as "zeller-congruence ( year month day -- n )" where n is +! the day of the week (Sunday is 0). + +: euler019 ( -- count ) + 1901 2000 [a,b] [ 12 [1,b] [ 1 zeller-congruence ] 1 map-withn ] map concat + [ 0 = ] subset length ; + +! [ euler019 ] 100 ave-time +! 1 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler019 From beaa4601ed5d0b84a4ea6641d49f4ce531bcf75f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 23 Dec 2007 14:57:39 -0500 Subject: [PATCH 11/67] XML combinator refactoring --- extra/xml/data/data.factor | 67 ++++++++++++---- extra/xml/generator/generator.factor | 2 +- extra/xml/literal.factor | 19 +++++ extra/xml/literal/literal.factor | 64 +++++++++++++++ extra/xml/test/soap.factor | 2 +- extra/xml/test/templating.factor | 4 +- extra/xml/test/test.factor | 89 ++++++++++----------- extra/xml/tokenize/tokenize.factor | 3 +- extra/xml/utilities/utilities.factor | 111 ++++++++------------------- extra/xml/writer/writer.factor | 9 +-- extra/xml/xml-docs.factor | 48 +++--------- extra/yahoo/yahoo.factor | 2 +- 12 files changed, 232 insertions(+), 188 deletions(-) create mode 100644 extra/xml/literal.factor create mode 100644 extra/xml/literal/literal.factor diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor index 77f7c4d929..f16a713dfc 100644 --- a/extra/xml/data/data.factor +++ b/extra/xml/data/data.factor @@ -41,17 +41,13 @@ C: instruction TUPLE: prolog version encoding standalone ; C: prolog -TUPLE: xml prolog before after ; -: ( prolog before main after -- xml ) - { set-xml-prolog set-xml-before set-delegate set-xml-after } - xml construct ; +TUPLE: tag attrs children ; -TUPLE: attrs ; -: ( alist -- attrs ) - attrs construct-delegate ; +TUPLE: attrs alist ; +C: attrs : attr@ ( key alist -- index {key,value} ) - >r assure-name r> + >r assure-name r> attrs-alist [ first names-match? ] curry* find ; M: attrs at* @@ -60,13 +56,13 @@ M: attrs set-at 2dup attr@ nip [ 2nip set-second ] [ - [ >r assure-name swap 2array r> ?push ] keep - set-delegate + >r assure-name swap 2array r> + [ attrs-alist ?push ] keep set-attrs-alist ] if* ; -M: attrs assoc-size length ; +M: attrs assoc-size attrs-alist length ; M: attrs new-assoc drop V{ } new ; -M: attrs >alist delegate >alist ; +M: attrs >alist attrs-alist >alist ; : >attrs ( assoc -- attrs ) dup [ @@ -77,13 +73,15 @@ M: attrs assoc-like drop dup attrs? [ >attrs ] unless ; M: attrs clear-assoc - f swap set-delegate ; + f swap set-attrs-alist ; M: attrs delete-at - tuck attr@ drop [ swap delete-nth ] [ drop ] if* ; + tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ; + +M: attrs clone + attrs-alist clone ; INSTANCE: attrs assoc -TUPLE: tag attrs children ; : ( name attrs children -- tag ) >r >r assure-name r> T{ attrs } assoc-like r> { set-delegate set-tag-attrs set-tag-children } @@ -97,6 +95,45 @@ INSTANCE: tag assoc CONSULT: sequence-protocol tag tag-children ; INSTANCE: tag sequence +M: tag like + over tag? [ + [ delegate ] keep tag-attrs + rot dup [ V{ } like ] when + ] unless ; + +M: tag clone + [ delegate clone ] keep [ tag-attrs clone ] keep + tag-children clone + { set-delegate set-tag-attrs set-tag-children } tag construct ; + +TUPLE: xml prolog before main after ; +: ( prolog before main after -- xml ) + { set-xml-prolog set-xml-before set-delegate set-xml-after } + xml construct ; + +CONSULT: sequence-protocol xml delegate ; +INSTANCE: xml sequence + +CONSULT: assoc-protocol xml delegate ; +INSTANCE: xml assoc + +xml ( xml tag -- newxml ) + swap [ dup xml-prolog swap xml-before rot ] keep xml-after ; + +: seq>xml ( xml seq -- newxml ) + over delegate like tag>xml ; +PRIVATE> + +M: xml clone + [ xml-prolog clone ] keep [ xml-before clone ] keep + [ delegate clone ] keep xml-after clone ; + +M: xml like + swap dup xml? [ + dup tag? [ tag>xml ] [ seq>xml ] if + ] unless ; + ! tag with children=f is contained : ( name attrs -- tag ) f ; diff --git a/extra/xml/generator/generator.factor b/extra/xml/generator/generator.factor index 84edc4e551..44bd1934f8 100644 --- a/extra/xml/generator/generator.factor +++ b/extra/xml/generator/generator.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel xml.data xml.utilities assocs splitting -sequences parser quotations sequences.lib ; +sequences parser quotations sequences.lib xml.utilities ; IN: xml.generator : comment, ( string -- ) , ; diff --git a/extra/xml/literal.factor b/extra/xml/literal.factor new file mode 100644 index 0000000000..9aad2c2166 --- /dev/null +++ b/extra/xml/literal.factor @@ -0,0 +1,19 @@ +USING: peg peg.ebnf kernel strings sequences combinators.lib ; +IN: xml.literal + +! EBNF-based XML generation syntax +! This is a terrible grammar for XML, only suitable for literals like this + +: &ident ( -- parser ) + [ { + [ printable? ] + [ blank? not ] + [ "<>" member? not ] + } <-&& ] satisfy ; + +: make-name ( str/3array -- name ) + dup array? [ first3 nip f ] [ name-tag ] if ; + + make-name +EBNF> diff --git a/extra/xml/literal/literal.factor b/extra/xml/literal/literal.factor new file mode 100644 index 0000000000..50d4753858 --- /dev/null +++ b/extra/xml/literal/literal.factor @@ -0,0 +1,64 @@ +USING: peg peg.ebnf kernel strings sequences combinators.lib arrays xml.data +namespaces assocs xml.generator ; +IN: xml.literal + +! EBNF-based XML generation syntax +! This is a terrible grammar for XML, only suitable for literals like this + +: &ident ( -- parser ) + [ { + [ printable? ] + [ blank? not ] + [ "<>" member? not ] + } <-&& ] satisfy repeat1 [ >string ] action ; + +: 2choice 2array choice ; + +: &name ( -- parser ) + &ident ":" token &ident 3array seq [ first3 nip f ] action + &ident [ ] action + 2choice ; + +: "e ( quote -- parser ) + [ token ] keep [ = not ] curry satisfy dupd seq swap seq ; + +DEFER: " +: &code ( -- parser ) + [ "[]" member? not ] satisfy [ " ] delay 2choice repeat0 ; + +: " ( -- parser ) + ! This doesn't deal with "[" or "]" properly + "[" token &code + "]" token 3array seq [ second parse ] action ; + +: &value ( -- parser ) + "'" "e "\"" "e " 3array choice ; + +: &attr ( -- parser ) + &name "=" token &value sp 3array seq [ first3 nip 2array ] action ; + +: &attrs ( -- parser ) + &attr repeat0 [ + [ swap [ set ] 2curry ] { } assoc>map concat + ] action ; + +: &tag-start ( -- parser ) + "<" token &name sp &attrs sp 3array seq + [ first3 2array nip ] action ; + +: tag-open-code ( {name,attrs} contents -- quot ) + swap first2 dup empty? [ drop swap [ tag, ] 3curry ] + [ swap rot [ >r >r H{ } make-assoc r> r> swapd tag*, ] 3curry ] if ; + +: &tag-open ( -- parser ) + &tag-start ">" token " 3array seq + [ first3 nip tag-open-code ] action ; + +: tag-contained-code ( {name,attrs} -- quot ) + first2 dup empty? [ drop [ contained, ] curry ] + [ swap [ >r H{ } make-assoc r> swap contained*, ] 2curry ] if ; + +: &tag-contained ( -- parser ) + &tag-start "/>" token 2array seq + [ first tag-contained-code ] action ; + diff --git a/extra/xml/test/soap.factor b/extra/xml/test/soap.factor index ed8bd70efc..f8bd8e1021 100644 --- a/extra/xml/test/soap.factor +++ b/extra/xml/test/soap.factor @@ -5,7 +5,7 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ; [ tag-named children>string ] curry* map ; : parse-result ( xml -- seq ) - "resultElements" tag-named* "item" tags-named + "resultElements" deep-tag-named "item" tags-named [ assemble-data ] map ; [ "http://www.foxnews.com/oreilly/" ] [ diff --git a/extra/xml/test/templating.factor b/extra/xml/test/templating.factor index baa0e3bca1..ca2d973510 100644 --- a/extra/xml/test/templating.factor +++ b/extra/xml/test/templating.factor @@ -1,6 +1,6 @@ IN: templating USING: kernel xml sequences assocs tools.test io arrays namespaces - xml.data xml.utilities xml.writer generic ; + xml.data xml.utilities xml.writer generic sequences.deep ; : sub-tag T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" } ; @@ -16,7 +16,7 @@ M: tag (r-ref) M: object (r-ref) drop ; : template ( xml -- ) - [ (r-ref) ] xml-each ; + [ (r-ref) ] deep-each ; ! Example diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index a2fd2813ed..8c4757517d 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -1,45 +1,48 @@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -IN: temporary -USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities +! Copyright (C) 2005, 2006 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +IN: temporary +USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities parser strings xml.data io.files xml.writer xml.utilities state-parser - continuations assocs ; - -! This is insufficient -SYMBOL: xml-file -[ ] [ "extra/xml/test/test.xml" resource-path - [ file>xml ] with-html-entities xml-file set ] unit-test -[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test -[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test -[ "a" ] [ xml-file get name-space ] unit-test -[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test -[ "that" ] [ - xml-file get T{ name f "" "this" "http://d.de" } swap at -] unit-test -[ t ] [ xml-file get tag-children second contained-tag? ] unit-test -[ t ] [ [ "" string>xml ] catch xml-parse-error? ] unit-test -[ T{ comment f "This is where the fun begins!" } ] [ - xml-file get xml-before [ comment? ] find nip -] unit-test -[ "xsl stylesheet=\"that-one.xsl\"" ] [ - xml-file get xml-after [ instruction? ] find nip instruction-text -] unit-test -[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test -[ "that" ] [ xml-file get "this" swap at ] unit-test -[ "" ] - [ "" string>xml xml>string ] unit-test -[ "abcd" ] [ - "
abcd
" string>xml - [ [ dup string? [ % ] [ drop ] if ] xml-each ] "" make -] unit-test -[ "abcd" ] [ - "
abcd
" string>xml - [ string? ] xml-subset concat -] unit-test -[ "foo" ] [ - "foo" string>xml - "c" get-id children>string -] unit-test -[ "foo" ] [ "" string>xml "y" over -at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test + continuations assocs sequences.deep ; + +! This is insufficient +SYMBOL: xml-file +[ ] [ "extra/xml/test/test.xml" resource-path + [ file>xml ] with-html-entities xml-file set ] unit-test +[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test +[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test +[ "a" ] [ xml-file get name-space ] unit-test +[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test +[ "that" ] [ + xml-file get T{ name f "" "this" "http://d.de" } swap at +] unit-test +[ t ] [ xml-file get tag-children second contained-tag? ] unit-test +[ t ] [ [ "" string>xml ] catch xml-parse-error? ] unit-test +[ T{ comment f "This is where the fun begins!" } ] [ + xml-file get xml-before [ comment? ] find nip +] unit-test +[ "xsl stylesheet=\"that-one.xsl\"" ] [ + xml-file get xml-after [ instruction? ] find nip instruction-text +] unit-test +[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test +[ "that" ] [ xml-file get "this" swap at ] unit-test +[ "" ] + [ "" string>xml xml>string ] unit-test +[ "abcd" ] [ + "
abcd
" string>xml + [ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make +] unit-test +[ "abcd" ] [ + "
abcd
" string>xml + [ string? ] deep-subset concat +] unit-test +[ "foo" ] [ + "foo" string>xml + "c" get-id children>string +] unit-test +[ "foo" ] [ "" string>xml "y" over + at swap "z" >r tuck r> swap set-at + T{ name f "blah" "z" f } swap at ] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test +[ "bar baz" ] +[ "bar" string>xml [ " baz" append ] map xml>string ] unit-test diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index 5e3bf1edfa..85a473f503 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -124,7 +124,8 @@ SYMBOL: ns-stack [ parse-attr (middle-tag) ] when ; : middle-tag ( -- attrs-alist ) - [ (middle-tag) ] V{ } make pass-blank ; + ! f make will make a vector if it has any elements + [ (middle-tag) ] f make pass-blank ; : end-tag ( name attrs-alist -- tag ) tag-ns pass-blank get-char CHAR: / = diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index fe64684f22..2d2c6a1d04 100644 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences words io assocs quotations strings parser arrays xml.data xml.writer debugger -splitting vectors ; +splitting vectors sequences.deep ; IN: xml.utilities ! * System for words specialized on tag names @@ -59,59 +59,6 @@ M: process-missing error. : first-child-tag ( tag -- tag ) tag-children [ tag? ] find nip ; -! * Utilities for searching through XML documents -! These all work from the outside in, top to bottom. - -: with-delegate ( object quot -- object ) - over clone >r >r delegate r> call r> - [ set-delegate ] keep ; inline - -GENERIC# xml-each 1 ( quot tag -- ) inline -M: tag xml-each - [ call ] 2keep - swap tag-children [ swap xml-each ] curry* each ; -M: object xml-each - call ; -M: xml xml-each - >r delegate r> xml-each ; - -GENERIC# xml-map 1 ( quot tag -- tag ) inline -M: tag xml-map - swap clone over >r swap call r> - swap [ tag-children [ swap xml-map ] curry* map ] keep - [ set-tag-children ] keep ; -M: object xml-map - call ; -M: xml xml-map - swap [ swap xml-map ] with-delegate ; - -: xml-subset ( quot tag -- seq ) ! quot: tag -- ? - V{ } clone rot [ - swap >r [ swap call ] 2keep rot r> - swap [ [ push ] keep ] [ nip ] if - ] xml-each nip ; - -GENERIC# xml-find 1 ( quot tag -- tag ) inline -M: tag xml-find - [ call ] 2keep swap rot [ - f swap - [ nip over >r swap xml-find r> swap dup ] find - 2drop ! leaves result of quot - ] unless nip ; -M: object xml-find - keep f ? ; -M: xml xml-find - >r delegate r> xml-find ; - -GENERIC# xml-inject 1 ( quot tag -- ) inline -M: tag xml-inject - swap [ - swap [ call ] keep - [ xml-inject ] keep - ] change-each ; -M: object xml-inject 2drop ; -M: xml xml-inject >r delegate >r xml-inject ; - ! * Accessing part of an XML document ! for tag- words, a start means that it searches all children ! and no star searches only direct children @@ -119,11 +66,14 @@ M: xml xml-inject >r delegate >r xml-inject ; : tag-named? ( name elem -- ? ) dup tag? [ names-match? ] [ 2drop f ] if ; -: tag-named* ( tag name/string -- matching-tag ) - assure-name [ swap tag-named? ] curry xml-find ; +: tags@ ( tag name -- children name ) + >r { } like r> assure-name ; -: tags-named* ( tag name/string -- tags-seq ) - assure-name [ swap tag-named? ] curry xml-subset ; +: deep-tag-named ( tag name/string -- matching-tag ) + assure-name [ swap tag-named? ] curry deep-find ; + +: deep-tags-named ( tag name/string -- tags-seq ) + tags@ [ swap tag-named? ] curry deep-subset ; : tag-named ( tag name/string -- matching-tag ) ! like get-name-tag but only looks at direct children, @@ -131,7 +81,28 @@ M: xml xml-inject >r delegate >r xml-inject ; assure-name swap [ tag-named? ] curry* find nip ; : tags-named ( tag name/string -- tags-seq ) - assure-name swap [ tag-named? ] curry* subset ; + tags@ swap [ tag-named? ] curry* subset ; + +: tag-with-attr? ( elem attr-value attr-name -- ? ) + rot dup tag? [ at = ] [ 3drop f ] if ; + +: tag-with-attr ( tag attr-value attr-name -- matching-tag ) + assure-name [ tag-with-attr? ] 2curry find nip ; + +: tags-with-attr ( tag attr-value attr-name -- tags-seq ) + tags@ [ tag-with-attr? ] 2curry subset tag-children ; + +: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag ) + assure-name [ tag-with-attr? ] 2curry deep-find ; + +: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) + tags@ [ tag-with-attr? ] 2curry deep-subset ; + +: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) + "id" deep-tag-with-attr ; + +: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags ) + >r >r deep-tags-named r> r> tags-with-attr ; : assert-tag ( name name -- ) names-match? [ "Unexpected XML tag found" throw ] unless ; @@ -142,25 +113,3 @@ M: xml xml-inject >r delegate >r xml-inject ; : insert-child ( child tag -- ) >r 1vector r> insert-children ; - -: tag-with-attr? ( elem attr-value attr-name -- ? ) - rot dup tag? [ at = ] [ 3drop f ] if ; - -: tag-with-attr ( tag attr-value attr-name -- matching-tag ) - assure-name [ tag-with-attr? ] 2curry find nip ; - -: tags-with-attr ( tag attr-value attr-name -- tags-seq ) - assure-name [ tag-with-attr? ] 2curry subset ; - -: tag-with-attr* ( tag attr-value attr-name -- matching-tag ) - assure-name [ tag-with-attr? ] 2curry xml-find ; - -: tags-with-attr* ( tag attr-value attr-name -- tags-seq ) - assure-name [ tag-with-attr? ] 2curry xml-subset ; - -: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) - "id" tag-with-attr ; - -: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags ) - >r >r tags-named* r> r> tags-with-attr ; - diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 986f1b5a01..b0b707fd42 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -22,14 +22,14 @@ IN: xml.writer [ write CHAR: : write1 ] when* name-tag write ; -: print-attrs ( hash -- ) +: print-attrs ( assoc -- ) [ - first2 " " write + " " write swap print-name "=\"" write chars>entities write "\"" write - ] each ; + ] assoc-each ; GENERIC: write-item ( object -- ) @@ -38,8 +38,7 @@ M: string write-item M: contained-tag write-item CHAR: < write1 - dup print-name - tag-attrs print-attrs + dup print-name tag-attrs print-attrs "/>" write ; M: open-tag write-item diff --git a/extra/xml/xml-docs.factor b/extra/xml/xml-docs.factor index bb833585c0..e1c4d035fd 100644 --- a/extra/xml/xml-docs.factor +++ b/extra/xml/xml-docs.factor @@ -49,24 +49,6 @@ HELP: TAG: { $description "defines what a process should do when it encounters a specific tag" } { $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } { $see-also POSTPONE: PROCESS: } ; - -HELP: xml-each -{ $values { "tag" tag } { "quot" "a quotation ( element -- )" } } -{ $description "applies the quotation to each element (tags, strings, etc) in the tag, moving top-down" } -{ $see-also xml-map xml-subset } ; - -HELP: xml-map -{ $values { "tag" tag } { "quot" "a quotation ( element -- element )" } - { "tag" "an XML tag with the quotation applied to each element" } } -{ $description "applies the quotation to each element (tags, strings, etc) in the tag, moving top-down, and produces a new tag" } -{ $see-also xml-each xml-subset } ; - -HELP: xml-subset -{ $values { "tag" tag } { "quot" "a quotation ( tag -- ? )" } - { "seq" "sequence of elements" } } -{ $description "applies the quotation to each element (tags, strings, etc) in the tag, moving top-down, producing a sequence of elements which do not return false for the sequence" } -{ $see-also xml-map xml-each } ; - HELP: build-tag* { $values { "items" "sequence of elements" } { "name" "string" } { "tag" tag } } @@ -166,15 +148,10 @@ HELP: xml-chunk { $description "rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." } { $see-also write-chunk read-xml } ; -HELP: xml-find -{ $values { "tag" "an XML element or document" } { "quot" "a quotation ( elem -- ? )" } { "tag" "an XML element which satisfies the predicate" } } -{ $description "finds the first element in the XML document which satisfies the predicate, moving from the outermost element to the innermost, top-down" } -{ $see-also xml-each xml-map get-id } ; - HELP: get-id { $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } } { $description "finds the XML tag with the specified id, ignoring the namespace" } -{ $see-also xml-find } ; +{ $see-also } ; HELP: process { $values { "object" "an opener, closer, contained or text element" } } @@ -242,15 +219,15 @@ HELP: write-chunk { $description "writes an XML document fragment, ie a sequence of XML elements, to the " { $link stdio } " stream." } { $see-also write-item write-xml } ; -HELP: tag-named* +HELP: deep-tag-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } } { $description "finds an XML tag with a matching name, recursively searching children and children of children" } -{ $see-also tags-named tag-named tags-named* } ; +{ $see-also tags-named tag-named deep-tags-named } ; -HELP: tags-named* +HELP: deep-tags-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "tags-seq" "a sequence of tags" } } { $description "returns a sequence of all tags of a matching name, recursively searching children and children of children" } -{ $see-also tag-named tag-named* tags-named } ; +{ $see-also tag-named deep-tag-named tags-named } ; HELP: children>string { $values { "tag" "an XML tag or document" } { "string" "a string" } } @@ -306,14 +283,14 @@ HELP: tag-named { "name/string" "an XML name or string representing the name" } { "matching-tag" tag } } { $description "finds the first tag with matching name which is the direct child of the given tag" } -{ $see-also tags-named* tag-named* tags-named } ; +{ $see-also deep-tags-named deep-tag-named tags-named } ; HELP: tags-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing the name" } { "tags-seq" "a sequence of tags" } } { $description "finds all tags with matching name that are the direct children of the given tag" } -{ $see-also tag-named* tags-named* tag-named } ; +{ $see-also deep-tag-named deep-tags-named tag-named } ; HELP: state-parse { $values { "stream" "an input stream" } { "quot" "a quotation ( -- )" } } @@ -390,18 +367,13 @@ ARTICLE: { "xml" "utils" } "XML processing utilities" "System sfor creating words which dispatch on XML tags:" { $subsection POSTPONE: PROCESS: } { $subsection POSTPONE: TAG: } - "Combinators for traversing XML trees:" - { $subsection xml-each } - { $subsection xml-map } - { $subsection xml-subset } - { $subsection xml-find } "Getting parts of an XML document or tag:" $nl - "Note: the difference between tag-named* and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." + "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." { $subsection tag-named } { $subsection tags-named } - { $subsection tag-named* } - { $subsection tags-named* } + { $subsection deep-tag-named } + { $subsection deep-tags-named } { $subsection get-id } "Words for simplified generation of XML:" { $subsection build-tag* } diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 8bcb9139a7..371560367f 100644 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -9,7 +9,7 @@ TUPLE: result title url summary ; C: result : parse-yahoo ( xml -- seq ) - "Result" tags-named* [ + "Result" deep-tags-named [ { "Title" "Url" "Summary" } [ tag-named children>string ] curry* map first3 From 998213bb4b94d9298da4921b41e526134fbc9987 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 23 Dec 2007 14:58:56 -0500 Subject: [PATCH 12/67] Removed extra/xml/literal, which was added by accident --- extra/xml/literal.factor | 19 ---------- extra/xml/literal/literal.factor | 64 -------------------------------- 2 files changed, 83 deletions(-) delete mode 100644 extra/xml/literal.factor delete mode 100644 extra/xml/literal/literal.factor diff --git a/extra/xml/literal.factor b/extra/xml/literal.factor deleted file mode 100644 index 9aad2c2166..0000000000 --- a/extra/xml/literal.factor +++ /dev/null @@ -1,19 +0,0 @@ -USING: peg peg.ebnf kernel strings sequences combinators.lib ; -IN: xml.literal - -! EBNF-based XML generation syntax -! This is a terrible grammar for XML, only suitable for literals like this - -: &ident ( -- parser ) - [ { - [ printable? ] - [ blank? not ] - [ "<>" member? not ] - } <-&& ] satisfy ; - -: make-name ( str/3array -- name ) - dup array? [ first3 nip f ] [ name-tag ] if ; - - make-name -EBNF> diff --git a/extra/xml/literal/literal.factor b/extra/xml/literal/literal.factor deleted file mode 100644 index 50d4753858..0000000000 --- a/extra/xml/literal/literal.factor +++ /dev/null @@ -1,64 +0,0 @@ -USING: peg peg.ebnf kernel strings sequences combinators.lib arrays xml.data -namespaces assocs xml.generator ; -IN: xml.literal - -! EBNF-based XML generation syntax -! This is a terrible grammar for XML, only suitable for literals like this - -: &ident ( -- parser ) - [ { - [ printable? ] - [ blank? not ] - [ "<>" member? not ] - } <-&& ] satisfy repeat1 [ >string ] action ; - -: 2choice 2array choice ; - -: &name ( -- parser ) - &ident ":" token &ident 3array seq [ first3 nip f ] action - &ident [ ] action - 2choice ; - -: "e ( quote -- parser ) - [ token ] keep [ = not ] curry satisfy dupd seq swap seq ; - -DEFER: " -: &code ( -- parser ) - [ "[]" member? not ] satisfy [ " ] delay 2choice repeat0 ; - -: " ( -- parser ) - ! This doesn't deal with "[" or "]" properly - "[" token &code - "]" token 3array seq [ second parse ] action ; - -: &value ( -- parser ) - "'" "e "\"" "e " 3array choice ; - -: &attr ( -- parser ) - &name "=" token &value sp 3array seq [ first3 nip 2array ] action ; - -: &attrs ( -- parser ) - &attr repeat0 [ - [ swap [ set ] 2curry ] { } assoc>map concat - ] action ; - -: &tag-start ( -- parser ) - "<" token &name sp &attrs sp 3array seq - [ first3 2array nip ] action ; - -: tag-open-code ( {name,attrs} contents -- quot ) - swap first2 dup empty? [ drop swap [ tag, ] 3curry ] - [ swap rot [ >r >r H{ } make-assoc r> r> swapd tag*, ] 3curry ] if ; - -: &tag-open ( -- parser ) - &tag-start ">" token " 3array seq - [ first3 nip tag-open-code ] action ; - -: tag-contained-code ( {name,attrs} -- quot ) - first2 dup empty? [ drop [ contained, ] curry ] - [ swap [ >r H{ } make-assoc r> swap contained*, ] 2curry ] if ; - -: &tag-contained ( -- parser ) - &tag-start "/>" token 2array seq - [ first tag-contained-code ] action ; - From fc403b373bf324d24af25a2b6f4df5afd5b31c13 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 23 Dec 2007 22:20:57 -0500 Subject: [PATCH 13/67] Declared sigma and count to be inline --- extra/combinators/lib/lib.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 047887bcc8..e4d66d4725 100644 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -72,9 +72,9 @@ MACRO: nfirst ( n -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; +: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; inline -: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; +: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline : all-unique? ( seq -- ? ) [ prune ] keep [ length ] 2apply = ; From 0e13e2e92ce89f218242742418efa29a1f7ad89c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 23 Dec 2007 23:21:44 -0500 Subject: [PATCH 14/67] Fixing XML bug --- extra/xml/data/data.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor index f16a713dfc..d3f89d3807 100644 --- a/extra/xml/data/data.factor +++ b/extra/xml/data/data.factor @@ -62,7 +62,7 @@ M: attrs set-at M: attrs assoc-size attrs-alist length ; M: attrs new-assoc drop V{ } new ; -M: attrs >alist attrs-alist >alist ; +M: attrs >alist attrs-alist ; : >attrs ( assoc -- attrs ) dup [ @@ -130,9 +130,9 @@ M: xml clone [ delegate clone ] keep xml-after clone ; M: xml like - swap dup xml? [ + swap dup xml? [ nip ] [ dup tag? [ tag>xml ] [ seq>xml ] if - ] unless ; + ] if ; ! tag with children=f is contained : ( name attrs -- tag ) From 5fd3d343027239100c8f742588d377ec6e4bdf4a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 24 Dec 2007 00:06:53 -0500 Subject: [PATCH 15/67] New math.text vocab converts numbers to English --- extra/math/text/authors.txt | 1 + extra/math/text/summary.txt | 1 + extra/math/text/text-docs.factor | 7 ++ extra/math/text/text-tests.factor | 15 +++++ extra/math/text/text.factor | 103 ++++++++++++++++++++++++++++++ 5 files changed, 127 insertions(+) create mode 100644 extra/math/text/authors.txt create mode 100644 extra/math/text/summary.txt create mode 100644 extra/math/text/text-docs.factor create mode 100644 extra/math/text/text-tests.factor create mode 100644 extra/math/text/text.factor diff --git a/extra/math/text/authors.txt b/extra/math/text/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/math/text/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/math/text/summary.txt b/extra/math/text/summary.txt new file mode 100644 index 0000000000..96b2f4f151 --- /dev/null +++ b/extra/math/text/summary.txt @@ -0,0 +1 @@ +Convert integers to text diff --git a/extra/math/text/text-docs.factor b/extra/math/text/text-docs.factor new file mode 100644 index 0000000000..6a896b1a82 --- /dev/null +++ b/extra/math/text/text-docs.factor @@ -0,0 +1,7 @@ +USING: help.markup help.syntax math strings ; +IN: math.text + +HELP: number>text +{ $values { "n" integer } { "str" string } } +{ $description "Converts an integer to a text string representation in English, including appropriate punctuation and conjunctions." } +{ $examples { $example "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ; diff --git a/extra/math/text/text-tests.factor b/extra/math/text/text-tests.factor new file mode 100644 index 0000000000..09c8a0461b --- /dev/null +++ b/extra/math/text/text-tests.factor @@ -0,0 +1,15 @@ +USING: math.functions math.text tools.test ; +IN: temporary + +[ "Zero" ] [ 0 number>text ] unit-test +[ "Twenty-One" ] [ 21 number>text ] unit-test +[ "One Hundred" ] [ 100 number>text ] unit-test +[ "One Hundred and One" ] [ 101 number>text ] unit-test +[ "One Thousand and One" ] [ 1001 number>text ] unit-test +[ "One Thousand, One Hundred and One" ] [ 1101 number>text ] unit-test +[ "One Million, One Thousand and One" ] [ 1001001 number>text ] unit-test +[ "One Million, One Thousand, One Hundred and One" ] [ 1001101 number>text ] unit-test +[ "One Million, One Hundred and Eleven Thousand, One Hundred and Eleven" ] [ 1111111 number>text ] unit-test +[ "One Duotrigintillion" ] [ 10 99 ^ number>text ] unit-test + +[ "Negative One Hundred and Twenty-Three" ] [ -123 number>text ] unit-test diff --git a/extra/math/text/text.factor b/extra/math/text/text.factor new file mode 100644 index 0000000000..7298fd3c15 --- /dev/null +++ b/extra/math/text/text.factor @@ -0,0 +1,103 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.functions math.parser namespaces + sequences splitting sequences.lib ; +IN: math.text + + ] + } && and-needed? set drop ; + +: negative-text ( n -- str ) + 0 < "Negative " "" ? ; + +: 3digit-groups ( n -- seq ) + number>string 3 + [ reverse 10 string>integer ] map ; + +: hundreds-place ( n -- str ) + 100 /mod swap dup zero? [ + 2drop "" + ] [ + small-numbers " Hundred" append + swap zero? [ " and " append ] unless + ] if ; + +: tens-place ( n -- str ) + 100 mod dup 20 >= [ + 10 /mod >r tens r> + dup zero? [ drop ] [ "-" swap small-numbers 3append ] if + ] [ + dup zero? [ drop "" ] [ small-numbers ] if + ] if ; + +: 3digits>text ( n -- str ) + dup hundreds-place swap tens-place append ; + +: text-with-scale ( index seq -- str ) + dupd nth 3digits>text swap + scale-numbers dup empty? [ + drop + ] [ + " " swap 3append + ] if ; + +: append-with-conjunction ( str1 str2 -- newstr ) + over length zero? [ + nip + ] [ + and-needed? get " and " ", " ? rot 3append + and-needed? off + ] if ; + +: (recombine) ( str index seq -- newstr seq ) + 2dup nth zero? [ + nip + ] [ + [ text-with-scale ] keep + -rot append-with-conjunction swap + ] if ; + +: recombine ( seq -- str ) + dup singleton? [ + first 3digits>text + ] [ + dup set-conjunction "" swap + dup length [ swap (recombine) ] each drop + ] if ; + +: (number>text) ( n -- str ) + dup negative-text swap abs 3digit-groups recombine append ; + +PRIVATE> + +: number>text ( n -- str ) + dup zero? [ + small-numbers + ] [ + [ (number>text) ] with-scope + ] if ; + From d830ed9314ff8fb3058c58fde7ac6003da706146 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 24 Dec 2007 01:58:13 -0500 Subject: [PATCH 16/67] extra/tuple-syntax--named tuple slot literals --- extra/tuple-syntax/about.txt | 1 + extra/tuple-syntax/authors.txt | 1 + extra/tuple-syntax/tags.txt | 1 + extra/tuple-syntax/tuple-syntax-docs.factor | 10 ++++++++++ extra/tuple-syntax/tuple-syntax-tests.factor | 7 +++++++ extra/tuple-syntax/tuple-syntax.factor | 21 ++++++++++++++++++++ 6 files changed, 41 insertions(+) create mode 100644 extra/tuple-syntax/about.txt create mode 100644 extra/tuple-syntax/authors.txt create mode 100644 extra/tuple-syntax/tags.txt create mode 100644 extra/tuple-syntax/tuple-syntax-docs.factor create mode 100644 extra/tuple-syntax/tuple-syntax-tests.factor create mode 100644 extra/tuple-syntax/tuple-syntax.factor diff --git a/extra/tuple-syntax/about.txt b/extra/tuple-syntax/about.txt new file mode 100644 index 0000000000..f243374925 --- /dev/null +++ b/extra/tuple-syntax/about.txt @@ -0,0 +1 @@ +Tuple literals with named slots diff --git a/extra/tuple-syntax/authors.txt b/extra/tuple-syntax/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/tuple-syntax/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/tuple-syntax/tags.txt b/extra/tuple-syntax/tags.txt new file mode 100644 index 0000000000..71c0ff7282 --- /dev/null +++ b/extra/tuple-syntax/tags.txt @@ -0,0 +1 @@ +syntax diff --git a/extra/tuple-syntax/tuple-syntax-docs.factor b/extra/tuple-syntax/tuple-syntax-docs.factor new file mode 100644 index 0000000000..7d4c12c0e9 --- /dev/null +++ b/extra/tuple-syntax/tuple-syntax-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax tuple-syntax ; + +HELP: TUPLE{ +{ $syntax "TUPLE{ class slot-name: value... }" } +{ $values { "class" "a tuple class word" } { "slot-name" "the name of a slot, without the tuple class name" } { "value" "the value for a slot" } } +{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } ". The class word must be specified. Slots which aren't specified are set to f. If slot names are duplicated, the latest one is used." } +{ $see-also POSTPONE: T{ } ; + +IN: tuple-syntax +ABOUT: POSTPONE: TUPLE{ diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor new file mode 100644 index 0000000000..b16c5b337d --- /dev/null +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -0,0 +1,7 @@ +USING: tools.test tuple-syntax ; + +TUPLE: foo bar baz ; + +[ T{ foo } ] [ TUPLE{ foo } ] unit-test +[ T{ foo 1 { 2 3 } { 4 { 5 } } } ] +[ TUPLE{ foo bar: { 2 3 } delegate: 1 baz: { 4 { 5 } } } ] unit-test diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor new file mode 100644 index 0000000000..ddc90a8961 --- /dev/null +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -0,0 +1,21 @@ +USING: kernel sequences slots parser words classes ; +IN: tuple-syntax + +! TUPLE: foo bar baz ; +! TUPLE{ foo bar: 1 baz: 2 } + +: parse-object ( -- object ) + scan-word dup parsing? [ V{ } clone swap execute first ] when ; + +: parse-slot-writer ( tuple -- slot-setter ) + scan dup "}" = [ 2drop f ] [ + 1 head* swap class "slots" word-prop + [ slot-spec-name = ] curry* find nip slot-spec-writer + ] if ; + +: parse-slots ( accum tuple -- accum tuple ) + dup parse-slot-writer + [ parse-object pick rot execute parse-slots ] when* ; + +: TUPLE{ + scan-word construct-empty parse-slots parsed ; parsing From 50c3b5de14d1ed47a38ff0fcb72d1cd699fc3fdf Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 24 Dec 2007 04:32:19 -0500 Subject: [PATCH 17/67] Solutions to Project Euler problems 18 and 67 Added appropriate words to common.factor and got rid of number>digits for the time being. --- extra/project-euler/016/016.factor | 5 +- extra/project-euler/018/018.factor | 75 +++++++++++++++++ extra/project-euler/067/067.factor | 58 +++++++++++++ extra/project-euler/067/triangle.txt | 100 +++++++++++++++++++++++ extra/project-euler/common/common.factor | 28 +++++-- extra/project-euler/project-euler.factor | 3 +- 6 files changed, 256 insertions(+), 13 deletions(-) create mode 100644 extra/project-euler/018/018.factor create mode 100644 extra/project-euler/067/067.factor create mode 100644 extra/project-euler/067/triangle.txt diff --git a/extra/project-euler/016/016.factor b/extra/project-euler/016/016.factor index a8b2aea0b7..f3f414808d 100644 --- a/extra/project-euler/016/016.factor +++ b/extra/project-euler/016/016.factor @@ -16,11 +16,8 @@ IN: project-euler.016 ! SOLUTION ! -------- -: number>digits ( n -- seq ) - number>string string>digits ; - : euler016 ( -- answer ) - 2 1000 ^ number>digits sum ; + 2 1000 ^ number>string string>digits sum ; ! [ euler016 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor new file mode 100644 index 0000000000..559d613328 --- /dev/null +++ b/extra/project-euler/018/018.factor @@ -0,0 +1,75 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel project-euler.common ; +IN: project-euler.018 + +! http://projecteuler.net/index.php?section=problems&id=18 + +! DESCRIPTION +! ----------- + +! By starting at the top of the triangle below and moving to adjacent numbers +! on the row below, the maximum total from top to bottom is 23. + +! 3 +! 7 5 +! 2 4 6 +! 8 5 9 3 + +! That is, 3 + 7 + 4 + 9 = 23. + +! Find the maximum total from top to bottom of the triangle below: + +! 75 +! 95 64 +! 17 47 82 +! 18 35 87 10 +! 20 04 82 47 65 +! 19 01 23 75 03 34 +! 88 02 77 73 07 63 67 +! 99 65 04 28 06 16 70 92 +! 41 41 26 56 83 40 80 70 33 +! 41 48 72 33 47 32 37 16 94 29 +! 53 71 44 65 25 43 91 52 97 51 14 +! 70 11 33 28 77 73 17 78 39 68 17 57 +! 91 71 52 38 17 14 91 43 58 50 27 29 48 +! 63 66 04 68 89 53 67 30 73 16 69 87 40 31 +! 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 + +! NOTE: As there are only 16384 routes, it is possible to solve this problem by +! trying every route. However, Problem 67, is the same challenge with a +! triangle containing one-hundred rows; it cannot be solved by brute force, and +! requires a clever method! ;o) + + +! SOLUTION +! -------- + + + +: euler018 ( -- answer ) + source-018 max-path ; + +! [ euler018 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler018 diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor new file mode 100644 index 0000000000..4e3a3df2ce --- /dev/null +++ b/extra/project-euler/067/067.factor @@ -0,0 +1,58 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.files kernel math.parser namespaces project-euler.common sequences + splitting system vocabs ; +IN: project-euler.067 + +! http://projecteuler.net/index.php?section=problems&id=67 + +! DESCRIPTION +! ----------- + +! By starting at the top of the triangle below and moving to adjacent numbers +! on the row below, the maximum total from top to bottom is 23. + +! 3 +! 7 5 +! 2 4 6 +! 8 5 9 3 + +! That is, 3 + 7 + 4 + 9 = 23. + +! Find the maximum total from top to bottom in triangle.txt (right click and +! 'Save Link/Target As...'), a 15K text file containing a triangle with +! one-hundred rows. + +! NOTE: This is a much more difficult version of Problem 18. It is not possible +! to try every route to solve this problem, as there are 2^99 altogether! If you +! could check one trillion (10^12) routes every second it would take over twenty +! billion years to check them all. There is an efficient algorithm to solve it. ;o) + + +! SOLUTION +! -------- + + lines [ " " split [ string>number ] map ] map ; + +PRIVATE> + +: euler067 ( -- answer ) + source-067 max-path ; + +! [ euler067 ] 100 ave-time +! 15 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler067 diff --git a/extra/project-euler/067/triangle.txt b/extra/project-euler/067/triangle.txt new file mode 100644 index 0000000000..00f98e3eba --- /dev/null +++ b/extra/project-euler/067/triangle.txt @@ -0,0 +1,100 @@ +59 +73 41 +52 40 09 +26 53 06 34 +10 51 87 86 81 +61 95 66 57 25 68 +90 81 80 38 92 67 73 +30 28 51 76 81 18 75 44 +84 14 95 87 62 81 17 78 58 +21 46 71 58 02 79 62 39 31 09 +56 34 35 53 78 31 81 18 90 93 15 +78 53 04 21 84 93 32 13 97 11 37 51 +45 03 81 79 05 18 78 86 13 30 63 99 95 +39 87 96 28 03 38 42 17 82 87 58 07 22 57 +06 17 51 17 07 93 09 07 75 97 95 78 87 08 53 +67 66 59 60 88 99 94 65 55 77 55 34 27 53 78 28 +76 40 41 04 87 16 09 42 75 69 23 97 30 60 10 79 87 +12 10 44 26 21 36 32 84 98 60 13 12 36 16 63 31 91 35 +70 39 06 05 55 27 38 48 28 22 34 35 62 62 15 14 94 89 86 +66 56 68 84 96 21 34 34 34 81 62 40 65 54 62 05 98 03 02 60 +38 89 46 37 99 54 34 53 36 14 70 26 02 90 45 13 31 61 83 73 47 +36 10 63 96 60 49 41 05 37 42 14 58 84 93 96 17 09 43 05 43 06 59 +66 57 87 57 61 28 37 51 84 73 79 15 39 95 88 87 43 39 11 86 77 74 18 +54 42 05 79 30 49 99 73 46 37 50 02 45 09 54 52 27 95 27 65 19 45 26 45 +71 39 17 78 76 29 52 90 18 99 78 19 35 62 71 19 23 65 93 85 49 33 75 09 02 +33 24 47 61 60 55 32 88 57 55 91 54 46 57 07 77 98 52 80 99 24 25 46 78 79 05 +92 09 13 55 10 67 26 78 76 82 63 49 51 31 24 68 05 57 07 54 69 21 67 43 17 63 12 +24 59 06 08 98 74 66 26 61 60 13 03 09 09 24 30 71 08 88 70 72 70 29 90 11 82 41 34 +66 82 67 04 36 60 92 77 91 85 62 49 59 61 30 90 29 94 26 41 89 04 53 22 83 41 09 74 90 +48 28 26 37 28 52 77 26 51 32 18 98 79 36 62 13 17 08 19 54 89 29 73 68 42 14 08 16 70 37 +37 60 69 70 72 71 09 59 13 60 38 13 57 36 09 30 43 89 30 39 15 02 44 73 05 73 26 63 56 86 12 +55 55 85 50 62 99 84 77 28 85 03 21 27 22 19 26 82 69 54 04 13 07 85 14 01 15 70 59 89 95 10 19 +04 09 31 92 91 38 92 86 98 75 21 05 64 42 62 84 36 20 73 42 21 23 22 51 51 79 25 45 85 53 03 43 22 +75 63 02 49 14 12 89 14 60 78 92 16 44 82 38 30 72 11 46 52 90 27 08 65 78 03 85 41 57 79 39 52 33 48 +78 27 56 56 39 13 19 43 86 72 58 95 39 07 04 34 21 98 39 15 39 84 89 69 84 46 37 57 59 35 59 50 26 15 93 +42 89 36 27 78 91 24 11 17 41 05 94 07 69 51 96 03 96 47 90 90 45 91 20 50 56 10 32 36 49 04 53 85 92 25 65 +52 09 61 30 61 97 66 21 96 92 98 90 06 34 96 60 32 69 68 33 75 84 18 31 71 50 84 63 03 03 19 11 28 42 75 45 45 +61 31 61 68 96 34 49 39 05 71 76 59 62 67 06 47 96 99 34 21 32 47 52 07 71 60 42 72 94 56 82 83 84 40 94 87 82 46 +01 20 60 14 17 38 26 78 66 81 45 95 18 51 98 81 48 16 53 88 37 52 69 95 72 93 22 34 98 20 54 27 73 61 56 63 60 34 63 +93 42 94 83 47 61 27 51 79 79 45 01 44 73 31 70 83 42 88 25 53 51 30 15 65 94 80 44 61 84 12 77 02 62 02 65 94 42 14 94 +32 73 09 67 68 29 74 98 10 19 85 48 38 31 85 67 53 93 93 77 47 67 39 72 94 53 18 43 77 40 78 32 29 59 24 06 02 83 50 60 66 +32 01 44 30 16 51 15 81 98 15 10 62 86 79 50 62 45 60 70 38 31 85 65 61 64 06 69 84 14 22 56 43 09 48 66 69 83 91 60 40 36 61 +92 48 22 99 15 95 64 43 01 16 94 02 99 19 17 69 11 58 97 56 89 31 77 45 67 96 12 73 08 20 36 47 81 44 50 64 68 85 40 81 85 52 09 +91 35 92 45 32 84 62 15 19 64 21 66 06 01 52 80 62 59 12 25 88 28 91 50 40 16 22 99 92 79 87 51 21 77 74 77 07 42 38 42 74 83 02 05 +46 19 77 66 24 18 05 32 02 84 31 99 92 58 96 72 91 36 62 99 55 29 53 42 12 37 26 58 89 50 66 19 82 75 12 48 24 87 91 85 02 07 03 76 86 +99 98 84 93 07 17 33 61 92 20 66 60 24 66 40 30 67 05 37 29 24 96 03 27 70 62 13 04 45 47 59 88 43 20 66 15 46 92 30 04 71 66 78 70 53 99 +67 60 38 06 88 04 17 72 10 99 71 07 42 25 54 05 26 64 91 50 45 71 06 30 67 48 69 82 08 56 80 67 18 46 66 63 01 20 08 80 47 07 91 16 03 79 87 +18 54 78 49 80 48 77 40 68 23 60 88 58 80 33 57 11 69 55 53 64 02 94 49 60 92 16 35 81 21 82 96 25 24 96 18 02 05 49 03 50 77 06 32 84 27 18 38 +68 01 50 04 03 21 42 94 53 24 89 05 92 26 52 36 68 11 85 01 04 42 02 45 15 06 50 04 53 73 25 74 81 88 98 21 67 84 79 97 99 20 95 04 40 46 02 58 87 +94 10 02 78 88 52 21 03 88 60 06 53 49 71 20 91 12 65 07 49 21 22 11 41 58 99 36 16 09 48 17 24 52 36 23 15 72 16 84 56 02 99 43 76 81 71 29 39 49 17 +64 39 59 84 86 16 17 66 03 09 43 06 64 18 63 29 68 06 23 07 87 14 26 35 17 12 98 41 53 64 78 18 98 27 28 84 80 67 75 62 10 11 76 90 54 10 05 54 41 39 66 +43 83 18 37 32 31 52 29 95 47 08 76 35 11 04 53 35 43 34 10 52 57 12 36 20 39 40 55 78 44 07 31 38 26 08 15 56 88 86 01 52 62 10 24 32 05 60 65 53 28 57 99 +03 50 03 52 07 73 49 92 66 80 01 46 08 67 25 36 73 93 07 42 25 53 13 96 76 83 87 90 54 89 78 22 78 91 73 51 69 09 79 94 83 53 09 40 69 62 10 79 49 47 03 81 30 +71 54 73 33 51 76 59 54 79 37 56 45 84 17 62 21 98 69 41 95 65 24 39 37 62 03 24 48 54 64 46 82 71 78 33 67 09 16 96 68 52 74 79 68 32 21 13 78 96 60 09 69 20 36 +73 26 21 44 46 38 17 83 65 98 07 23 52 46 61 97 33 13 60 31 70 15 36 77 31 58 56 93 75 68 21 36 69 53 90 75 25 82 39 50 65 94 29 30 11 33 11 13 96 02 56 47 07 49 02 +76 46 73 30 10 20 60 70 14 56 34 26 37 39 48 24 55 76 84 91 39 86 95 61 50 14 53 93 64 67 37 31 10 84 42 70 48 20 10 72 60 61 84 79 69 65 99 73 89 25 85 48 92 56 97 16 +03 14 80 27 22 30 44 27 67 75 79 32 51 54 81 29 65 14 19 04 13 82 04 91 43 40 12 52 29 99 07 76 60 25 01 07 61 71 37 92 40 47 99 66 57 01 43 44 22 40 53 53 09 69 26 81 07 +49 80 56 90 93 87 47 13 75 28 87 23 72 79 32 18 27 20 28 10 37 59 21 18 70 04 79 96 03 31 45 71 81 06 14 18 17 05 31 50 92 79 23 47 09 39 47 91 43 54 69 47 42 95 62 46 32 85 +37 18 62 85 87 28 64 05 77 51 47 26 30 65 05 70 65 75 59 80 42 52 25 20 44 10 92 17 71 95 52 14 77 13 24 55 11 65 26 91 01 30 63 15 49 48 41 17 67 47 03 68 20 90 98 32 04 40 68 +90 51 58 60 06 55 23 68 05 19 76 94 82 36 96 43 38 90 87 28 33 83 05 17 70 83 96 93 06 04 78 47 80 06 23 84 75 23 87 72 99 14 50 98 92 38 90 64 61 58 76 94 36 66 87 80 51 35 61 38 +57 95 64 06 53 36 82 51 40 33 47 14 07 98 78 65 39 58 53 06 50 53 04 69 40 68 36 69 75 78 75 60 03 32 39 24 74 47 26 90 13 40 44 71 90 76 51 24 36 50 25 45 70 80 61 80 61 43 90 64 11 +18 29 86 56 68 42 79 10 42 44 30 12 96 18 23 18 52 59 02 99 67 46 60 86 43 38 55 17 44 93 42 21 55 14 47 34 55 16 49 24 23 29 96 51 55 10 46 53 27 92 27 46 63 57 30 65 43 27 21 20 24 83 +81 72 93 19 69 52 48 01 13 83 92 69 20 48 69 59 20 62 05 42 28 89 90 99 32 72 84 17 08 87 36 03 60 31 36 36 81 26 97 36 48 54 56 56 27 16 91 08 23 11 87 99 33 47 02 14 44 73 70 99 43 35 33 +90 56 61 86 56 12 70 59 63 32 01 15 81 47 71 76 95 32 65 80 54 70 34 51 40 45 33 04 64 55 78 68 88 47 31 47 68 87 03 84 23 44 89 72 35 08 31 76 63 26 90 85 96 67 65 91 19 14 17 86 04 71 32 95 +37 13 04 22 64 37 37 28 56 62 86 33 07 37 10 44 52 82 52 06 19 52 57 75 90 26 91 24 06 21 14 67 76 30 46 14 35 89 89 41 03 64 56 97 87 63 22 34 03 79 17 45 11 53 25 56 96 61 23 18 63 31 37 37 47 +77 23 26 70 72 76 77 04 28 64 71 69 14 85 96 54 95 48 06 62 99 83 86 77 97 75 71 66 30 19 57 90 33 01 60 61 14 12 90 99 32 77 56 41 18 14 87 49 10 14 90 64 18 50 21 74 14 16 88 05 45 73 82 47 74 44 +22 97 41 13 34 31 54 61 56 94 03 24 59 27 98 77 04 09 37 40 12 26 87 09 71 70 07 18 64 57 80 21 12 71 83 94 60 39 73 79 73 19 97 32 64 29 41 07 48 84 85 67 12 74 95 20 24 52 41 67 56 61 29 93 35 72 69 +72 23 63 66 01 11 07 30 52 56 95 16 65 26 83 90 50 74 60 18 16 48 43 77 37 11 99 98 30 94 91 26 62 73 45 12 87 73 47 27 01 88 66 99 21 41 95 80 02 53 23 32 61 48 32 43 43 83 14 66 95 91 19 81 80 67 25 88 +08 62 32 18 92 14 83 71 37 96 11 83 39 99 05 16 23 27 10 67 02 25 44 11 55 31 46 64 41 56 44 74 26 81 51 31 45 85 87 09 81 95 22 28 76 69 46 48 64 87 67 76 27 89 31 11 74 16 62 03 60 94 42 47 09 34 94 93 72 +56 18 90 18 42 17 42 32 14 86 06 53 33 95 99 35 29 15 44 20 49 59 25 54 34 59 84 21 23 54 35 90 78 16 93 13 37 88 54 19 86 67 68 55 66 84 65 42 98 37 87 56 33 28 58 38 28 38 66 27 52 21 81 15 08 22 97 32 85 27 +91 53 40 28 13 34 91 25 01 63 50 37 22 49 71 58 32 28 30 18 68 94 23 83 63 62 94 76 80 41 90 22 82 52 29 12 18 56 10 08 35 14 37 57 23 65 67 40 72 39 93 39 70 89 40 34 07 46 94 22 20 05 53 64 56 30 05 56 61 88 27 +23 95 11 12 37 69 68 24 66 10 87 70 43 50 75 07 62 41 83 58 95 93 89 79 45 39 02 22 05 22 95 43 62 11 68 29 17 40 26 44 25 71 87 16 70 85 19 25 59 94 90 41 41 80 61 70 55 60 84 33 95 76 42 63 15 09 03 40 38 12 03 32 +09 84 56 80 61 55 85 97 16 94 82 94 98 57 84 30 84 48 93 90 71 05 95 90 73 17 30 98 40 64 65 89 07 79 09 19 56 36 42 30 23 69 73 72 07 05 27 61 24 31 43 48 71 84 21 28 26 65 65 59 65 74 77 20 10 81 61 84 95 08 52 23 70 +47 81 28 09 98 51 67 64 35 51 59 36 92 82 77 65 80 24 72 53 22 07 27 10 21 28 30 22 48 82 80 48 56 20 14 43 18 25 50 95 90 31 77 08 09 48 44 80 90 22 93 45 82 17 13 96 25 26 08 73 34 99 06 49 24 06 83 51 40 14 15 10 25 01 +54 25 10 81 30 64 24 74 75 80 36 75 82 60 22 69 72 91 45 67 03 62 79 54 89 74 44 83 64 96 66 73 44 30 74 50 37 05 09 97 70 01 60 46 37 91 39 75 75 18 58 52 72 78 51 81 86 52 08 97 01 46 43 66 98 62 81 18 70 93 73 08 32 46 34 +96 80 82 07 59 71 92 53 19 20 88 66 03 26 26 10 24 27 50 82 94 73 63 08 51 33 22 45 19 13 58 33 90 15 22 50 36 13 55 06 35 47 82 52 33 61 36 27 28 46 98 14 73 20 73 32 16 26 80 53 47 66 76 38 94 45 02 01 22 52 47 96 64 58 52 39 +88 46 23 39 74 63 81 64 20 90 33 33 76 55 58 26 10 46 42 26 74 74 12 83 32 43 09 02 73 55 86 54 85 34 28 23 29 79 91 62 47 41 82 87 99 22 48 90 20 05 96 75 95 04 43 28 81 39 81 01 28 42 78 25 39 77 90 57 58 98 17 36 73 22 63 74 51 +29 39 74 94 95 78 64 24 38 86 63 87 93 06 70 92 22 16 80 64 29 52 20 27 23 50 14 13 87 15 72 96 81 22 08 49 72 30 70 24 79 31 16 64 59 21 89 34 96 91 48 76 43 53 88 01 57 80 23 81 90 79 58 01 80 87 17 99 86 90 72 63 32 69 14 28 88 69 +37 17 71 95 56 93 71 35 43 45 04 98 92 94 84 96 11 30 31 27 31 60 92 03 48 05 98 91 86 94 35 90 90 08 48 19 33 28 68 37 59 26 65 96 50 68 22 07 09 49 34 31 77 49 43 06 75 17 81 87 61 79 52 26 27 72 29 50 07 98 86 01 17 10 46 64 24 18 56 +51 30 25 94 88 85 79 91 40 33 63 84 49 67 98 92 15 26 75 19 82 05 18 78 65 93 61 48 91 43 59 41 70 51 22 15 92 81 67 91 46 98 11 11 65 31 66 10 98 65 83 21 05 56 05 98 73 67 46 74 69 34 08 30 05 52 07 98 32 95 30 94 65 50 24 63 28 81 99 57 +19 23 61 36 09 89 71 98 65 17 30 29 89 26 79 74 94 11 44 48 97 54 81 55 39 66 69 45 28 47 13 86 15 76 74 70 84 32 36 33 79 20 78 14 41 47 89 28 81 05 99 66 81 86 38 26 06 25 13 60 54 55 23 53 27 05 89 25 23 11 13 54 59 54 56 34 16 24 53 44 06 +13 40 57 72 21 15 60 08 04 19 11 98 34 45 09 97 86 71 03 15 56 19 15 44 97 31 90 04 87 87 76 08 12 30 24 62 84 28 12 85 82 53 99 52 13 94 06 65 97 86 09 50 94 68 69 74 30 67 87 94 63 07 78 27 80 36 69 41 06 92 32 78 37 82 30 05 18 87 99 72 19 99 +44 20 55 77 69 91 27 31 28 81 80 27 02 07 97 23 95 98 12 25 75 29 47 71 07 47 78 39 41 59 27 76 13 15 66 61 68 35 69 86 16 53 67 63 99 85 41 56 08 28 33 40 94 76 90 85 31 70 24 65 84 65 99 82 19 25 54 37 21 46 33 02 52 99 51 33 26 04 87 02 08 18 96 +54 42 61 45 91 06 64 79 80 82 32 16 83 63 42 49 19 78 65 97 40 42 14 61 49 34 04 18 25 98 59 30 82 72 26 88 54 36 21 75 03 88 99 53 46 51 55 78 22 94 34 40 68 87 84 25 30 76 25 08 92 84 42 61 40 38 09 99 40 23 29 39 46 55 10 90 35 84 56 70 63 23 91 39 +52 92 03 71 89 07 09 37 68 66 58 20 44 92 51 56 13 71 79 99 26 37 02 06 16 67 36 52 58 16 79 73 56 60 59 27 44 77 94 82 20 50 98 33 09 87 94 37 40 83 64 83 58 85 17 76 53 02 83 52 22 27 39 20 48 92 45 21 09 42 24 23 12 37 52 28 50 78 79 20 86 62 73 20 59 +54 96 80 15 91 90 99 70 10 09 58 90 93 50 81 99 54 38 36 10 30 11 35 84 16 45 82 18 11 97 36 43 96 79 97 65 40 48 23 19 17 31 64 52 65 65 37 32 65 76 99 79 34 65 79 27 55 33 03 01 33 27 61 28 66 08 04 70 49 46 48 83 01 45 19 96 13 81 14 21 31 79 93 85 50 05 +92 92 48 84 59 98 31 53 23 27 15 22 79 95 24 76 05 79 16 93 97 89 38 89 42 83 02 88 94 95 82 21 01 97 48 39 31 78 09 65 50 56 97 61 01 07 65 27 21 23 14 15 80 97 44 78 49 35 33 45 81 74 34 05 31 57 09 38 94 07 69 54 69 32 65 68 46 68 78 90 24 28 49 51 45 86 35 +41 63 89 76 87 31 86 09 46 14 87 82 22 29 47 16 13 10 70 72 82 95 48 64 58 43 13 75 42 69 21 12 67 13 64 85 58 23 98 09 37 76 05 22 31 12 66 50 29 99 86 72 45 25 10 28 19 06 90 43 29 31 67 79 46 25 74 14 97 35 76 37 65 46 23 82 06 22 30 76 93 66 94 17 96 13 20 72 +63 40 78 08 52 09 90 41 70 28 36 14 46 44 85 96 24 52 58 15 87 37 05 98 99 39 13 61 76 38 44 99 83 74 90 22 53 80 56 98 30 51 63 39 44 30 91 91 04 22 27 73 17 35 53 18 35 45 54 56 27 78 48 13 69 36 44 38 71 25 30 56 15 22 73 43 32 69 59 25 93 83 45 11 34 94 44 39 92 +12 36 56 88 13 96 16 12 55 54 11 47 19 78 17 17 68 81 77 51 42 55 99 85 66 27 81 79 93 42 65 61 69 74 14 01 18 56 12 01 58 37 91 22 42 66 83 25 19 04 96 41 25 45 18 69 96 88 36 93 10 12 98 32 44 83 83 04 72 91 04 27 73 07 34 37 71 60 59 31 01 54 54 44 96 93 83 36 04 45 +30 18 22 20 42 96 65 79 17 41 55 69 94 81 29 80 91 31 85 25 47 26 43 49 02 99 34 67 99 76 16 14 15 93 08 32 99 44 61 77 67 50 43 55 87 55 53 72 17 46 62 25 50 99 73 05 93 48 17 31 70 80 59 09 44 59 45 13 74 66 58 94 87 73 16 14 85 38 74 99 64 23 79 28 71 42 20 37 82 31 23 +51 96 39 65 46 71 56 13 29 68 53 86 45 33 51 49 12 91 21 21 76 85 02 17 98 15 46 12 60 21 88 30 92 83 44 59 42 50 27 88 46 86 94 73 45 54 23 24 14 10 94 21 20 34 23 51 04 83 99 75 90 63 60 16 22 33 83 70 11 32 10 50 29 30 83 46 11 05 31 17 86 42 49 01 44 63 28 60 07 78 95 40 +44 61 89 59 04 49 51 27 69 71 46 76 44 04 09 34 56 39 15 06 94 91 75 90 65 27 56 23 74 06 23 33 36 69 14 39 05 34 35 57 33 22 76 46 56 10 61 65 98 09 16 69 04 62 65 18 99 76 49 18 72 66 73 83 82 40 76 31 89 91 27 88 17 35 41 35 32 51 32 67 52 68 74 85 80 57 07 11 62 66 47 22 67 +65 37 19 97 26 17 16 24 24 17 50 37 64 82 24 36 32 11 68 34 69 31 32 89 79 93 96 68 49 90 14 23 04 04 67 99 81 74 70 74 36 96 68 09 64 39 88 35 54 89 96 58 66 27 88 97 32 14 06 35 78 20 71 06 85 66 57 02 58 91 72 05 29 56 73 48 86 52 09 93 22 57 79 42 12 01 31 68 17 59 63 76 07 77 +73 81 14 13 17 20 11 09 01 83 08 85 91 70 84 63 62 77 37 07 47 01 59 95 39 69 39 21 99 09 87 02 97 16 92 36 74 71 90 66 33 73 73 75 52 91 11 12 26 53 05 26 26 48 61 50 90 65 01 87 42 47 74 35 22 73 24 26 56 70 52 05 48 41 31 18 83 27 21 39 80 85 26 08 44 02 71 07 63 22 05 52 19 08 20 +17 25 21 11 72 93 33 49 64 23 53 82 03 13 91 65 85 02 40 05 42 31 77 42 05 36 06 54 04 58 07 76 87 83 25 57 66 12 74 33 85 37 74 32 20 69 03 97 91 68 82 44 19 14 89 28 85 85 80 53 34 87 58 98 88 78 48 65 98 40 11 57 10 67 70 81 60 79 74 72 97 59 79 47 30 20 54 80 89 91 14 05 33 36 79 39 +60 85 59 39 60 07 57 76 77 92 06 35 15 72 23 41 45 52 95 18 64 79 86 53 56 31 69 11 91 31 84 50 44 82 22 81 41 40 30 42 30 91 48 94 74 76 64 58 74 25 96 57 14 19 03 99 28 83 15 75 99 01 89 85 79 50 03 95 32 67 44 08 07 41 62 64 29 20 14 76 26 55 48 71 69 66 19 72 44 25 14 01 48 74 12 98 07 +64 66 84 24 18 16 27 48 20 14 47 69 30 86 48 40 23 16 61 21 51 50 26 47 35 33 91 28 78 64 43 68 04 79 51 08 19 60 52 95 06 68 46 86 35 97 27 58 04 65 30 58 99 12 12 75 91 39 50 31 42 64 70 04 46 07 98 73 98 93 37 89 77 91 64 71 64 65 66 21 78 62 81 74 42 20 83 70 73 95 78 45 92 27 34 53 71 15 +30 11 85 31 34 71 13 48 05 14 44 03 19 67 23 73 19 57 06 90 94 72 57 69 81 62 59 68 88 57 55 69 49 13 07 87 97 80 89 05 71 05 05 26 38 40 16 62 45 99 18 38 98 24 21 26 62 74 69 04 85 57 77 35 58 67 91 79 79 57 86 28 66 34 72 51 76 78 36 95 63 90 08 78 47 63 45 31 22 70 52 48 79 94 15 77 61 67 68 +23 33 44 81 80 92 93 75 94 88 23 61 39 76 22 03 28 94 32 06 49 65 41 34 18 23 08 47 62 60 03 63 33 13 80 52 31 54 73 43 70 26 16 69 57 87 83 31 03 93 70 81 47 95 77 44 29 68 39 51 56 59 63 07 25 70 07 77 43 53 64 03 94 42 95 39 18 01 66 21 16 97 20 50 90 16 70 10 95 69 29 06 25 61 41 26 15 59 63 35 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 73de3a7208..9c27093913 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,9 +1,12 @@ USING: arrays kernel hashtables math math.functions math.miller-rabin - math.ranges namespaces sequences combinators.lib ; + math.parser math.ranges namespaces sequences combinators.lib ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution. +: nth-pair ( n seq -- nth next ) + over 1+ over nth >r nth r> ; + fixnum ; +: max-children ( seq -- seq ) + [ dup length 1- [ over nth-pair max , ] each ] { } make nip ; + PRIVATE> - -: divisor? ( n m -- ? ) - mod zero? ; - -: perfect-square? ( n -- ? ) - dup sqrt mod zero? ; - : collect-consecutive ( seq width -- seq ) [ 2dup count-shifts [ 2dup head shift-3rd , ] times ] { } make 2nip ; +: divisor? ( n m -- ? ) + mod zero? ; + +: max-path ( triangle -- n ) + dup length 1 > [ + 2 cut* first2 max-children [ + ] 2map add max-path + ] [ + first first + ] if ; + +: perfect-square? ( n -- ? ) + dup sqrt mod zero? ; + : prime-factorization ( n -- seq ) [ 2 [ over 1 > ] diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index c35101785a..51e40f6646 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -5,7 +5,8 @@ USING: io io.files kernel math.parser namespaces sequences strings project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 - project-euler.013 project-euler.014 project-euler.015 project-euler.016 ; + project-euler.013 project-euler.014 project-euler.015 project-euler.016 + project-euler.017 ; IN: project-euler Date: Mon, 24 Dec 2007 04:36:40 -0500 Subject: [PATCH 18/67] Alternate solution for Project Euler problem 17 Used the new vocab math.text and a string buffer. --- extra/project-euler/010/010.factor | 5 +---- extra/project-euler/017/017.factor | 23 +++++++++++++++++------ 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor index 7518eb2f6f..06b38eedf0 100644 --- a/extra/project-euler/010/010.factor +++ b/extra/project-euler/010/010.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel lazy-lists math math.erato math.functions math.ranges - namespaces sequences ; + namespaces sequences ; IN: project-euler.010 ! http://projecteuler.net/index.php?section=problems&id=10 @@ -22,9 +22,6 @@ IN: project-euler.010 : euler010 ( -- answer ) 0 1000000 lerato [ + ] leach ; -! TODO: solution is still too slow for 1000000, probably due to seq-diff -! calling member? for each number that we want to remove - ! [ euler010 ] time ! 765 ms run / 7 ms GC time diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor index 7568872743..cb85728b47 100644 --- a/extra/project-euler/017/017.factor +++ b/extra/project-euler/017/017.factor @@ -1,6 +1,6 @@ -! Copyright (c) 2007 Samuel Tardieu. +! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces sequences strings ; +USING: kernel math math.text namespaces ranges sequences strings ; IN: project-euler.017 ! http://projecteuler.net/index.php?section=problems&id=17 @@ -18,6 +18,7 @@ IN: project-euler.017 ! forty-two) contains 23 letters and 115 (one hundred and fifteen) contains ! 20 letters. + ! SOLUTION ! -------- @@ -38,18 +39,18 @@ IN: project-euler.017 DEFER: make-english : maybe-add ( n sep -- ) - over 0 = [ 2drop ] [ % make-english ] if ; + over zero? [ 2drop ] [ % make-english ] if ; : 0-99 ( n -- ) dup 20 < [ units ] [ 10 /mod swap tenths "-" maybe-add ] if ; : 0-999 ( n -- ) 100 /mod swap - dup 0 = [ drop 0-99 ] [ units " hundred" % " and " maybe-add ] if ; + dup zero? [ drop 0-99 ] [ units " hundred" % " and " maybe-add ] if ; : make-english ( n -- ) 1000 /mod swap - dup 0 = [ drop 0-999 ] [ 0-999 " thousand" % " and " maybe-add ] if ; + dup zero? [ drop 0-999 ] [ 0-999 " thousand" % " and " maybe-add ] if ; PRIVATE> @@ -57,9 +58,19 @@ PRIVATE> [ make-english ] "" make ; : euler017 ( -- answer ) - 1000 [ 1 + >english [ letter? ] subset length ] map sum ; + 1000 [1,b] [ >english [ letter? ] subset length ] map sum ; ! [ euler017 ] 100 ave-time ! 9 ms run / 0 ms GC ave time - 100 trials + +! ALTERNATE SOLUTIONS +! ------------------- + +: euler017a ( -- answer ) + 1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ alpha? ] count ; + +! [ euler017a ] 100 ave-time +! 14 ms run / 1 ms GC ave time - 100 trials + MAIN: euler017 From 207e752464e4e58c03cb5a3772c484a2b9571a03 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 24 Dec 2007 13:01:11 -0500 Subject: [PATCH 19/67] Typo on Project Euler USING math.ranges --- extra/project-euler/017/017.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor index cb85728b47..c87cd3920e 100644 --- a/extra/project-euler/017/017.factor +++ b/extra/project-euler/017/017.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.text namespaces ranges sequences strings ; +USING: kernel math math.ranges math.text namespaces sequences strings ; IN: project-euler.017 ! http://projecteuler.net/index.php?section=problems&id=17 From 2aa9dc9dde9b354d7022be531aec009efba22436 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 24 Dec 2007 13:07:46 -0500 Subject: [PATCH 20/67] Use Letter? instead of alpha? on euler017a --- extra/project-euler/017/017.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor index c87cd3920e..1fdb6c5484 100644 --- a/extra/project-euler/017/017.factor +++ b/extra/project-euler/017/017.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.ranges math.text namespaces sequences strings ; +USING: combinators.lib kernel math math.ranges math.text namespaces sequences + strings ; IN: project-euler.017 ! http://projecteuler.net/index.php?section=problems&id=17 @@ -68,7 +69,7 @@ PRIVATE> ! ------------------- : euler017a ( -- answer ) - 1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ alpha? ] count ; + 1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ Letter? ] count ; ! [ euler017a ] 100 ave-time ! 14 ms run / 1 ms GC ave time - 100 trials From 85a5beed74b5578eb9558c9a85711779284d806c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 24 Dec 2007 13:20:52 -0500 Subject: [PATCH 21/67] Adding sequences.deep --- extra/sequences/deep/authors.txt | 1 + extra/sequences/deep/deep-docs.factor | 29 +++++++++++++++++ extra/sequences/deep/deep-tests.factor | 25 +++++++++++++++ extra/sequences/deep/deep.factor | 44 ++++++++++++++++++++++++++ extra/sequences/deep/summary.txt | 1 + 5 files changed, 100 insertions(+) create mode 100644 extra/sequences/deep/authors.txt create mode 100644 extra/sequences/deep/deep-docs.factor create mode 100644 extra/sequences/deep/deep-tests.factor create mode 100644 extra/sequences/deep/deep.factor create mode 100644 extra/sequences/deep/summary.txt diff --git a/extra/sequences/deep/authors.txt b/extra/sequences/deep/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/sequences/deep/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/sequences/deep/deep-docs.factor b/extra/sequences/deep/deep-docs.factor new file mode 100644 index 0000000000..7a27bbdc1d --- /dev/null +++ b/extra/sequences/deep/deep-docs.factor @@ -0,0 +1,29 @@ +USING: help.syntax help.markup sequences.deep ; + +HELP: deep-each +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ) " } } +{ $description "Execute a quotation on each nested element of an object and its children, in preorder." } ; + +HELP: deep-map +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } { "newobj" "the mapped object" } } +{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } ; + +HELP: deep-subset +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "seq" "a sequence" } } +{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ; + +HELP: deep-find +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "elt" "an element" } } +{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } ; + +HELP: deep-contains? +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "?" "a boolean" } } +{ $description "Tests whether the given object or any subnode satisfies the given quotation." } ; + +HELP: flatten +{ $values { "obj" "an object" } { "seq" "a sequence" } } +{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ; + +HELP: deep-change-each +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } } +{ $description "Modifies each sub-node of an object in place, in preorder." } ; diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor new file mode 100644 index 0000000000..9c02d52089 --- /dev/null +++ b/extra/sequences/deep/deep-tests.factor @@ -0,0 +1,25 @@ +USING: sequences.deep kernel tools.test strings math arrays +namespaces sequences ; + +[ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test + +[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find* ] unit-test + +[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find* ] unit-test + +[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test + +: change-something ( seq -- newseq ) + dup array? [ "hi" add ] [ "hello" append ] if ; + +[ { { "heyhello" "hihello" } "hihello" } ] +[ "hey" 1array 1array [ change-something ] deep-map ] unit-test + +[ { { "heyhello" "hihello" } } ] +[ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test + +[ t ] [ "foo" [ string? ] deep-contains? ] unit-test + +[ "foo" ] [ "foo" [ string? ] deep-find ] unit-test + +[ { { 1 2 } 1 2 } ] [ [ { 1 2 } [ , ] deep-each ] { } make ] unit-test diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor new file mode 100644 index 0000000000..6e36878b78 --- /dev/null +++ b/extra/sequences/deep/deep.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel strings math ; +IN: sequences.deep + +! All traversal goes in postorder + +GENERIC: branch? ( object -- ? ) +M: sequence branch? drop t ; +M: string branch? drop f ; +M: number branch? drop f ; +M: object branch? drop f ; + +: deep-each ( obj quot -- ) + [ call ] 2keep over branch? + [ [ deep-each ] curry each ] [ 2drop ] if ; inline + +: deep-map ( obj quot -- newobj ) + [ call ] keep over branch? + [ [ deep-map ] curry map ] [ drop ] if ; inline + +: deep-subset ( obj quot -- seq ) + over >r + pusher >r deep-each r> + r> dup branch? [ like ] [ drop ] if ; inline + +: deep-find* ( obj quot -- elt ? ) + [ call ] 2keep rot [ drop t ] [ + over branch? [ + f -rot [ >r nip r> deep-find* ] curry find drop >boolean + ] [ 2drop f f ] if + ] if ; inline + +: deep-find ( obj quot -- elt ) deep-find* drop ; inline + +: deep-contains? ( obj quot -- ? ) deep-find* nip ; inline + +: deep-change-each ( obj quot -- ) + over branch? [ [ + [ call ] keep over >r deep-change-each r> + ] curry change-each ] [ 2drop ] if ; inline + +: flatten ( obj -- seq ) + [ branch? not ] deep-subset ; diff --git a/extra/sequences/deep/summary.txt b/extra/sequences/deep/summary.txt new file mode 100644 index 0000000000..60ad867782 --- /dev/null +++ b/extra/sequences/deep/summary.txt @@ -0,0 +1 @@ +Sequence/tree combinators like deep-map, deep-each, etc From 319d96384e428c2d34cc6b45e5fb875f81aa829b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 24 Dec 2007 16:29:04 -0500 Subject: [PATCH 22/67] Solution to Project Euler problem 19 --- extra/project-euler/019/019.factor | 54 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 2 +- 2 files changed, 55 insertions(+), 1 deletion(-) create mode 100644 extra/project-euler/019/019.factor diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor new file mode 100644 index 0000000000..26f16c0b8f --- /dev/null +++ b/extra/project-euler/019/019.factor @@ -0,0 +1,54 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar combinators.lib kernel math namespaces ; +IN: project-euler.019 + +! http://projecteuler.net/index.php?section=problems&id=19 + +! DESCRIPTION +! ----------- + +! You are given the following information, but you may prefer to do some +! research for yourself. + +! * 1 Jan 1900 was a Monday. +! * Thirty days has September, April, June and November. All the rest have +! thirty-one, Saving February alone, Which has twenty-eight, rain or +! shine. And on leap years, twenty-nine. +! * A leap year occurs on any year evenly divisible by 4, but not on a +! century unless it is divisible by 400. + +! How many Sundays fell on the first of the month during the twentieth century +! (1 Jan 1901 to 31 Dec 2000)? + + +! SOLUTION +! -------- + += [ + dup day-of-week , 1 +month (first-days) + ] [ + 2drop + ] if ; + +: first-days ( start-date end-date -- seq ) + [ swap (first-days) ] { } make ; + +PRIVATE> + +: euler019 ( -- answer ) + start-date end-date first-days [ zero? ] count ; + +! [ euler019 ] 100 ave-time +! 131 ms run / 3 ms GC ave time - 100 trials + +MAIN: euler019 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 51e40f6646..acf9215d58 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -6,7 +6,7 @@ USING: io io.files kernel math.parser namespaces sequences strings project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 project-euler.013 project-euler.014 project-euler.015 project-euler.016 - project-euler.017 ; + project-euler.017 project-euler.018 project-euler.019 project-euler.067 ; IN: project-euler Date: Mon, 24 Dec 2007 20:48:29 -0500 Subject: [PATCH 23/67] Fixed XML bug which made everything stop compiling --- extra/delegate/delegate.factor | 4 +++- extra/xml/data/data.factor | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 962746ec1a..8ff5e2110b 100644 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -45,8 +45,10 @@ PROTOCOL: sequence-protocol set-nth set-nth-unsafe length set-length lengthen ; PROTOCOL: assoc-protocol - at* assoc-size >alist assoc-find set-at + at* assoc-size >alist set-at assoc-clone-like delete-at clear-assoc new-assoc assoc-like ; + ! assoc-find excluded because GENERIC# 1 + ! everything should work, just slower (with >alist) PROTOCOL: stream-protocol stream-close stream-read1 stream-read stream-read-until diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor index d3f89d3807..ae54816471 100644 --- a/extra/xml/data/data.factor +++ b/extra/xml/data/data.factor @@ -96,10 +96,10 @@ CONSULT: sequence-protocol tag tag-children ; INSTANCE: tag sequence M: tag like - over tag? [ + over tag? [ drop ] [ [ delegate ] keep tag-attrs rot dup [ V{ } like ] when - ] unless ; + ] if ; M: tag clone [ delegate clone ] keep [ tag-attrs clone ] keep From 5b87577f91845e0e100d525da98436ba2ab2cd2f Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 24 Dec 2007 21:54:39 -0500 Subject: [PATCH 24/67] Solution for Project Euler problem 20 --- extra/project-euler/020/020.factor | 25 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 3 ++- 2 files changed, 27 insertions(+), 1 deletion(-) create mode 100644 extra/project-euler/020/020.factor diff --git a/extra/project-euler/020/020.factor b/extra/project-euler/020/020.factor new file mode 100644 index 0000000000..de40586165 --- /dev/null +++ b/extra/project-euler/020/020.factor @@ -0,0 +1,25 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.combinatorics math.parser sequences ; +IN: project-euler.020 + +! http://projecteuler.net/index.php?section=problems&id=20 + +! DESCRIPTION +! ----------- + +! n! means n * (n - 1) * ... * 3 * 2 * 1 + +! Find the sum of the digits in the number 100! + + +! SOLUTION +! -------- + +: euler020 ( -- answer ) + 100 factorial number>string string>digits sum ; + +! [ euler020 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler020 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index acf9215d58..48c1d272f0 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -6,7 +6,8 @@ USING: io io.files kernel math.parser namespaces sequences strings project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 project-euler.013 project-euler.014 project-euler.015 project-euler.016 - project-euler.017 project-euler.018 project-euler.019 project-euler.067 ; + project-euler.017 project-euler.018 project-euler.019 project-euler.020 + project-euler.067 ; IN: project-euler Date: Tue, 25 Dec 2007 00:13:01 -0500 Subject: [PATCH 25/67] Solution to Project Euler problem 21 --- extra/project-euler/016/016.factor | 4 +-- extra/project-euler/020/020.factor | 4 +-- extra/project-euler/021/021.factor | 46 ++++++++++++++++++++++++ extra/project-euler/common/common.factor | 17 ++++----- extra/project-euler/project-euler.factor | 6 ++-- 5 files changed, 62 insertions(+), 15 deletions(-) create mode 100644 extra/project-euler/021/021.factor diff --git a/extra/project-euler/016/016.factor b/extra/project-euler/016/016.factor index f3f414808d..866b0ed522 100644 --- a/extra/project-euler/016/016.factor +++ b/extra/project-euler/016/016.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.functions math.parser sequences ; +USING: kernel math.functions math.parser project-euler.common sequences ; IN: project-euler.016 ! http://projecteuler.net/index.php?section=problems&id=16 @@ -17,7 +17,7 @@ IN: project-euler.016 ! -------- : euler016 ( -- answer ) - 2 1000 ^ number>string string>digits sum ; + 2 1000 ^ number>digits sum ; ! [ euler016 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/020/020.factor b/extra/project-euler/020/020.factor index de40586165..498aad16ad 100644 --- a/extra/project-euler/020/020.factor +++ b/extra/project-euler/020/020.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.combinatorics math.parser sequences ; +USING: kernel math.combinatorics math.parser project-euler.common sequences ; IN: project-euler.020 ! http://projecteuler.net/index.php?section=problems&id=20 @@ -17,7 +17,7 @@ IN: project-euler.020 ! -------- : euler020 ( -- answer ) - 100 factorial number>string string>digits sum ; + 100 factorial number>digits sum ; ! [ euler020 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor new file mode 100644 index 0000000000..eb8cc02511 --- /dev/null +++ b/extra/project-euler/021/021.factor @@ -0,0 +1,46 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.functions math.ranges namespaces + project-euler.common sequences ; +IN: project-euler.021 + +! http://projecteuler.net/index.php?section=problems&id=21 + +! DESCRIPTION +! ----------- + +! Let d(n) be defined as the sum of proper divisors of n (numbers less than n +! which divide evenly into n). + +! If d(a) = b and d(b) = a, where a != b, then a and b are an amicable pair and +! each of a and b are called amicable numbers. + +! For example, the proper divisors of 220 are 1, 2, 4, 5, 10, 11, 20, 22, 44, +! 55 and 110; therefore d(220) = 284. The proper divisors of 284 are 1, 2, 4, +! 71 and 142; so d(284) = 220. + +! Evaluate the sum of all the amicable numbers under 10000. + + +! SOLUTION +! -------- + +fixnum 2 swap [a,b] [ + [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each drop + ] { } make sum 1+ ; + +: amicable-pair? ( n m -- ? ) + { [ 2dup = not ] [ 2dup d = ] } && 2nip ; + +PRIVATE> + +: euler021 ( -- answer ) + 10000 [1,b] [ dup dup d amicable-pair? [ drop 0 ] unless ] sigma ; + +! [ euler021 ] 100 ave-time +! 328 ms run / 10 ms GC ave time - 100 trials + +MAIN: euler021 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 9c27093913..0a31df82b7 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -15,6 +15,9 @@ IN: project-euler.common : shift-3rd ( seq obj obj -- seq obj obj ) rot 1 tail -rot ; +: max-children ( seq -- seq ) + [ dup length 1- [ over nth-pair max , ] each ] { } make nip ; + : >multiplicity ( seq -- seq ) dup prune [ [ 2dup [ = ] curry count 2array , ] each @@ -23,12 +26,6 @@ IN: project-euler.common : reduce-2s ( n -- r s ) dup even? [ factor-2s >r 1+ r> ] [ 1 swap ] if ; -: tau-limit ( n -- n ) - sqrt floor >fixnum ; - -: max-children ( seq -- seq ) - [ dup length 1- [ over nth-pair max , ] each ] { } make nip ; - PRIVATE> : collect-consecutive ( seq width -- seq ) @@ -46,8 +43,11 @@ PRIVATE> first first ] if ; +: number>digits ( n -- seq ) + number>string string>digits ; + : perfect-square? ( n -- ? ) - dup sqrt mod zero? ; + dup sqrt divisor? ; : prime-factorization ( n -- seq ) [ @@ -68,6 +68,7 @@ PRIVATE> ! Optimized brute-force, is often faster than prime factorization : tau* ( n -- n ) - reduce-2s [ perfect-square? -1 0 ? ] keep dup tau-limit [1,b] [ + reduce-2s [ perfect-square? -1 0 ? ] keep + dup sqrt >fixnum [1,b] [ dupd divisor? [ >r 2 + r> ] when ] each drop * ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 48c1d272f0..bf913f60da 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,13 +1,13 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: io io.files kernel math.parser namespaces sequences strings - vocabs vocabs.loader system project-euler.ave-time + vocabs vocabs.loader system project-euler.ave-time project-euler.common project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 project-euler.013 project-euler.014 project-euler.015 project-euler.016 project-euler.017 project-euler.018 project-euler.019 project-euler.020 - project-euler.067 ; + project-euler.021 project-euler.067 ; IN: project-euler number ; : number>euler ( n -- str ) - number>string string>digits 3 0 pad-left [ number>string ] map concat ; + number>digits 3 0 pad-left [ number>string ] map concat ; : solution-path ( n -- str ) number>euler dup [ From d5baea215d3e886315ec2738d01a02615a4d49c7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 25 Dec 2007 02:28:55 -0500 Subject: [PATCH 26/67] Splay tree fixes --- extra/trees/splay/splay-tests.factor | 8 +++---- extra/trees/splay/splay.factor | 36 ++++++++++++++++++---------- extra/trees/trees.factor | 10 +++++++- 3 files changed, 36 insertions(+), 18 deletions(-) diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor index f3548947a8..eb2dafb1d2 100644 --- a/extra/trees/splay/splay-tests.factor +++ b/extra/trees/splay/splay-tests.factor @@ -8,7 +8,7 @@ IN: temporary 100 [ drop 100 random swap at drop ] curry* each ; : make-numeric-splay-tree ( n -- splay-tree ) - dup -rot [ pick set-at ] 2each ; + [ [ dupd set-at ] curry each ] keep ; [ t ] [ 100 make-numeric-splay-tree dup randomize-numeric-splay-tree @@ -18,10 +18,10 @@ IN: temporary [ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test [ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test -[ f ] [ f 4 pick set-at 4 swap at ] unit-test +[ f ] [ f 4 pick set-at 4 swap at ] unit-test ! Ensure that f can be a value -[ t ] [ f 4 pick set-at 4 swap key? ] unit-test +[ t ] [ f 4 pick set-at 4 swap key? ] unit-test [ { { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } } @@ -29,5 +29,5 @@ IN: temporary { { 4 "d" } { 5 "e" } { 6 "f" } { 1 "a" } { 2 "b" } { 3 "c" } -} >splay-tree >alist +} >splay >alist ] unit-test diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index f83cf15d1f..dd40a77501 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -5,10 +5,13 @@ prettyprint.backend trees generic ; IN: trees.splay TUPLE: splay ; + : ( -- splay-tree ) - splay construct-empty + \ splay construct-empty over set-delegate ; +INSTANCE: splay assoc + : rotate-right ( node -- node ) dup node-left [ node-right swap set-node-left ] 2keep @@ -74,7 +77,7 @@ DEFER: (splay) nip dup node-right swap f over set-node-right swap ] if ; -: (get-splay) ( key tree -- node ? ) +: get-splay ( key tree -- node ? ) 2dup splay tree-root cmp 0 = [ nip t ] [ @@ -94,36 +97,36 @@ DEFER: (splay) drop f ] if* ; -: (remove-splay) ( key tree -- ) - tuck (get-splay) nip [ - dup tree-count 1- over set-tree-count +: remove-splay ( key tree -- ) + tuck get-splay nip [ + dup dec-count dup node-right swap node-left splay-join swap set-tree-root ] [ drop ] if* ; -: (set-splay) ( value key tree -- ) - 2dup (get-splay) [ 2nip set-node-value ] [ - drop dup tree-count 1+ over set-tree-count +: set-splay ( value key tree -- ) + 2dup get-splay [ 2nip set-node-value ] [ + drop dup inc-count 2dup splay-split rot - >r node construct-boa r> set-tree-root + >r >r swapd r> node construct-boa r> set-tree-root ] if ; : new-root ( value key tree -- ) [ 1 swap set-tree-count ] keep - >r r> set-tree-root ; + >r swap r> set-tree-root ; M: splay set-at ( value key tree -- ) - dup tree-root [ (set-splay) ] [ new-root ] if ; + dup tree-root [ set-splay ] [ new-root ] if ; M: splay at* ( key tree -- value ? ) dup tree-root [ - (get-splay) >r dup [ node-value ] when r> + get-splay >r dup [ node-value ] when r> ] [ 2drop f f ] if ; M: splay delete-at ( key tree -- ) - dup tree-root [ (remove-splay) ] [ 2drop ] if ; + dup tree-root [ remove-splay ] [ 2drop ] if ; M: splay new-assoc 2drop ; @@ -140,3 +143,10 @@ M: splay assoc-like ] unless ; M: splay pprint-delims drop \ SPLAY{ \ } ; +M: splay >pprint-sequence >alist ; +M: splay pprint-narrow? drop t ; + +! When tuple inheritance is used, the following lines won't be necessary +M: splay assoc-size tree-count ; +M: splay clear-assoc delegate clear-assoc ; +M: splay assoc-find >r tree-root r> find-node ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 372d9b2501..8c88e6f159 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -8,6 +8,8 @@ TUPLE: tree root count ; : ( -- tree ) f 0 tree construct-boa ; +INSTANCE: tree assoc + TUPLE: node key value left right ; : ( key value -- node ) f f node construct-boa ; @@ -19,6 +21,12 @@ SYMBOL: current-side : go-left? ( -- ? ) current-side get left = ; +: inc-count ( tree -- ) + dup tree-count 1+ swap set-tree-count ; + +: dec-count ( tree -- ) + dup tree-count 1- swap set-tree-count ; + : node-link@ ( node ? -- node ) go-left? xor [ node-left ] [ node-right ] if ; : set-node-link@ ( left parent ? -- ) @@ -60,7 +68,7 @@ SYMBOL: current-side ] [ choose-branch node-at* ] if - ] [ f f ] if* ; + ] [ drop f f ] if* ; M: tree at* ( key tree -- value ? ) tree-root node-at* ; From 2ab01a8f25827acdd9e952907ca35fd4d36ce997 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 25 Dec 2007 15:08:37 -0500 Subject: [PATCH 27/67] Fix amicable-pair? false positives --- extra/project-euler/021/021.factor | 8 ++++---- extra/project-euler/067/067.factor | 3 +++ 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor index eb8cc02511..cc0ba5b88d 100644 --- a/extra/project-euler/021/021.factor +++ b/extra/project-euler/021/021.factor @@ -32,13 +32,13 @@ IN: project-euler.021 [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each drop ] { } make sum 1+ ; -: amicable-pair? ( n m -- ? ) - { [ 2dup = not ] [ 2dup d = ] } && 2nip ; - PRIVATE> +: amicable? ( n -- ? ) + dup d { [ 2dup = not ] [ 2dup d = ] } && 2nip ; + : euler021 ( -- answer ) - 10000 [1,b] [ dup dup d amicable-pair? [ drop 0 ] unless ] sigma ; + 10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ; ! [ euler021 ] 100 ave-time ! 328 ms run / 10 ms GC ave time - 100 trials diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index 4e3a3df2ce..cdd788b0f3 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -55,4 +55,7 @@ PRIVATE> ! [ euler067 ] 100 ave-time ! 15 ms run / 0 ms GC ave time - 100 trials +! source-067 [ max-path ] curry 100 ave-time +! 3 ms run / 0 ms GC ave time - 100 trials + MAIN: euler067 From 994fe7c142b359c73a4d7520c84d72a9fc0c6809 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 26 Dec 2007 02:25:10 -0500 Subject: [PATCH 28/67] Solution to Project Euler problem 22 --- extra/project-euler/022/022.factor | 75 ++++++++++++++++++++++++ extra/project-euler/022/names.txt | 1 + extra/project-euler/project-euler.factor | 2 +- 3 files changed, 77 insertions(+), 1 deletion(-) create mode 100644 extra/project-euler/022/022.factor create mode 100644 extra/project-euler/022/names.txt diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor new file mode 100644 index 0000000000..fb9930df67 --- /dev/null +++ b/extra/project-euler/022/022.factor @@ -0,0 +1,75 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib io io.files kernel math math.parser namespaces sequences + sorting splitting strings system vocabs ; +IN: project-euler.022 + +! http://projecteuler.net/index.php?section=problems&id=22 + +! DESCRIPTION +! ----------- + +! Using names.txt (right click and 'Save Link/Target As...'), a 46K text file +! containing over five-thousand first names, begin by sorting it into +! alphabetical order. Then working out the alphabetical value for each name, +! multiply this value by its alphabetical position in the list to obtain a name +! score. + +! For example, when the list is sorted into alphabetical order, COLIN, which is +! worth 3 + 15 + 12 + 9 + 14 = 53, is the 938th name in the list. So, COLIN +! would obtain a score of 938 * 53 = 49714. + +! What is the total of all the name scores in the file? + + +! SOLUTION +! -------- + + contents [ quotable? ] subset "," split ; + +: alpha-value ( str -- n ) + string>digits [ 9 - ] sigma ; + +: name-score ( str seq -- n ) + over alpha-value -rot index 1+ * ; + +PRIVATE> + +: euler022 ( -- answer ) + source-022 natural-sort dup [ over name-score ] sigma nip ; + +! [ euler022 ] 100 ave-time +! 906 ms run / 1 ms GC ave time - 100 trials + +! source-022 [ natural-sort dup [ over name-score ] sigma nip ] curry 100 ave-time +! 850 ms run / 0 ms GC ave time - 100 trials + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Take advantage of the names being ordered and eliminate calls to name-score + +: euler022a ( -- answer ) + source-022 natural-sort dup length [ 1+ swap alpha-value * ] 2map sum ; + +! [ euler022 ] 100 ave-time +! 60 ms run / 1 ms GC ave time - 100 trials + +! source-022 [ natural-sort dup length [ 1+ swap alpha-value * ] 2map sum ] curry 100 ave-time +! 47 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler022a diff --git a/extra/project-euler/022/names.txt b/extra/project-euler/022/names.txt new file mode 100644 index 0000000000..5f9cf17227 --- /dev/null +++ b/extra/project-euler/022/names.txt @@ -0,0 +1 @@ +"MARY","PATRICIA","LINDA","BARBARA","ELIZABETH","JENNIFER","MARIA","SUSAN","MARGARET","DOROTHY","LISA","NANCY","KAREN","BETTY","HELEN","SANDRA","DONNA","CAROL","RUTH","SHARON","MICHELLE","LAURA","SARAH","KIMBERLY","DEBORAH","JESSICA","SHIRLEY","CYNTHIA","ANGELA","MELISSA","BRENDA","AMY","ANNA","REBECCA","VIRGINIA","KATHLEEN","PAMELA","MARTHA","DEBRA","AMANDA","STEPHANIE","CAROLYN","CHRISTINE","MARIE","JANET","CATHERINE","FRANCES","ANN","JOYCE","DIANE","ALICE","JULIE","HEATHER","TERESA","DORIS","GLORIA","EVELYN","JEAN","CHERYL","MILDRED","KATHERINE","JOAN","ASHLEY","JUDITH","ROSE","JANICE","KELLY","NICOLE","JUDY","CHRISTINA","KATHY","THERESA","BEVERLY","DENISE","TAMMY","IRENE","JANE","LORI","RACHEL","MARILYN","ANDREA","KATHRYN","LOUISE","SARA","ANNE","JACQUELINE","WANDA","BONNIE","JULIA","RUBY","LOIS","TINA","PHYLLIS","NORMA","PAULA","DIANA","ANNIE","LILLIAN","EMILY","ROBIN","PEGGY","CRYSTAL","GLADYS","RITA","DAWN","CONNIE","FLORENCE","TRACY","EDNA","TIFFANY","CARMEN","ROSA","CINDY","GRACE","WENDY","VICTORIA","EDITH","KIM","SHERRY","SYLVIA","JOSEPHINE","THELMA","SHANNON","SHEILA","ETHEL","ELLEN","ELAINE","MARJORIE","CARRIE","CHARLOTTE","MONICA","ESTHER","PAULINE","EMMA","JUANITA","ANITA","RHONDA","HAZEL","AMBER","EVA","DEBBIE","APRIL","LESLIE","CLARA","LUCILLE","JAMIE","JOANNE","ELEANOR","VALERIE","DANIELLE","MEGAN","ALICIA","SUZANNE","MICHELE","GAIL","BERTHA","DARLENE","VERONICA","JILL","ERIN","GERALDINE","LAUREN","CATHY","JOANN","LORRAINE","LYNN","SALLY","REGINA","ERICA","BEATRICE","DOLORES","BERNICE","AUDREY","YVONNE","ANNETTE","JUNE","SAMANTHA","MARION","DANA","STACY","ANA","RENEE","IDA","VIVIAN","ROBERTA","HOLLY","BRITTANY","MELANIE","LORETTA","YOLANDA","JEANETTE","LAURIE","KATIE","KRISTEN","VANESSA","ALMA","SUE","ELSIE","BETH","JEANNE","VICKI","CARLA","TARA","ROSEMARY","EILEEN","TERRI","GERTRUDE","LUCY","TONYA","ELLA","STACEY","WILMA","GINA","KRISTIN","JESSIE","NATALIE","AGNES","VERA","WILLIE","CHARLENE","BESSIE","DELORES","MELINDA","PEARL","ARLENE","MAUREEN","COLLEEN","ALLISON","TAMARA","JOY","GEORGIA","CONSTANCE","LILLIE","CLAUDIA","JACKIE","MARCIA","TANYA","NELLIE","MINNIE","MARLENE","HEIDI","GLENDA","LYDIA","VIOLA","COURTNEY","MARIAN","STELLA","CAROLINE","DORA","JO","VICKIE","MATTIE","TERRY","MAXINE","IRMA","MABEL","MARSHA","MYRTLE","LENA","CHRISTY","DEANNA","PATSY","HILDA","GWENDOLYN","JENNIE","NORA","MARGIE","NINA","CASSANDRA","LEAH","PENNY","KAY","PRISCILLA","NAOMI","CAROLE","BRANDY","OLGA","BILLIE","DIANNE","TRACEY","LEONA","JENNY","FELICIA","SONIA","MIRIAM","VELMA","BECKY","BOBBIE","VIOLET","KRISTINA","TONI","MISTY","MAE","SHELLY","DAISY","RAMONA","SHERRI","ERIKA","KATRINA","CLAIRE","LINDSEY","LINDSAY","GENEVA","GUADALUPE","BELINDA","MARGARITA","SHERYL","CORA","FAYE","ADA","NATASHA","SABRINA","ISABEL","MARGUERITE","HATTIE","HARRIET","MOLLY","CECILIA","KRISTI","BRANDI","BLANCHE","SANDY","ROSIE","JOANNA","IRIS","EUNICE","ANGIE","INEZ","LYNDA","MADELINE","AMELIA","ALBERTA","GENEVIEVE","MONIQUE","JODI","JANIE","MAGGIE","KAYLA","SONYA","JAN","LEE","KRISTINE","CANDACE","FANNIE","MARYANN","OPAL","ALISON","YVETTE","MELODY","LUZ","SUSIE","OLIVIA","FLORA","SHELLEY","KRISTY","MAMIE","LULA","LOLA","VERNA","BEULAH","ANTOINETTE","CANDICE","JUANA","JEANNETTE","PAM","KELLI","HANNAH","WHITNEY","BRIDGET","KARLA","CELIA","LATOYA","PATTY","SHELIA","GAYLE","DELLA","VICKY","LYNNE","SHERI","MARIANNE","KARA","JACQUELYN","ERMA","BLANCA","MYRA","LETICIA","PAT","KRISTA","ROXANNE","ANGELICA","JOHNNIE","ROBYN","FRANCIS","ADRIENNE","ROSALIE","ALEXANDRA","BROOKE","BETHANY","SADIE","BERNADETTE","TRACI","JODY","KENDRA","JASMINE","NICHOLE","RACHAEL","CHELSEA","MABLE","ERNESTINE","MURIEL","MARCELLA","ELENA","KRYSTAL","ANGELINA","NADINE","KARI","ESTELLE","DIANNA","PAULETTE","LORA","MONA","DOREEN","ROSEMARIE","ANGEL","DESIREE","ANTONIA","HOPE","GINGER","JANIS","BETSY","CHRISTIE","FREDA","MERCEDES","MEREDITH","LYNETTE","TERI","CRISTINA","EULA","LEIGH","MEGHAN","SOPHIA","ELOISE","ROCHELLE","GRETCHEN","CECELIA","RAQUEL","HENRIETTA","ALYSSA","JANA","KELLEY","GWEN","KERRY","JENNA","TRICIA","LAVERNE","OLIVE","ALEXIS","TASHA","SILVIA","ELVIRA","CASEY","DELIA","SOPHIE","KATE","PATTI","LORENA","KELLIE","SONJA","LILA","LANA","DARLA","MAY","MINDY","ESSIE","MANDY","LORENE","ELSA","JOSEFINA","JEANNIE","MIRANDA","DIXIE","LUCIA","MARTA","FAITH","LELA","JOHANNA","SHARI","CAMILLE","TAMI","SHAWNA","ELISA","EBONY","MELBA","ORA","NETTIE","TABITHA","OLLIE","JAIME","WINIFRED","KRISTIE","MARINA","ALISHA","AIMEE","RENA","MYRNA","MARLA","TAMMIE","LATASHA","BONITA","PATRICE","RONDA","SHERRIE","ADDIE","FRANCINE","DELORIS","STACIE","ADRIANA","CHERI","SHELBY","ABIGAIL","CELESTE","JEWEL","CARA","ADELE","REBEKAH","LUCINDA","DORTHY","CHRIS","EFFIE","TRINA","REBA","SHAWN","SALLIE","AURORA","LENORA","ETTA","LOTTIE","KERRI","TRISHA","NIKKI","ESTELLA","FRANCISCA","JOSIE","TRACIE","MARISSA","KARIN","BRITTNEY","JANELLE","LOURDES","LAUREL","HELENE","FERN","ELVA","CORINNE","KELSEY","INA","BETTIE","ELISABETH","AIDA","CAITLIN","INGRID","IVA","EUGENIA","CHRISTA","GOLDIE","CASSIE","MAUDE","JENIFER","THERESE","FRANKIE","DENA","LORNA","JANETTE","LATONYA","CANDY","MORGAN","CONSUELO","TAMIKA","ROSETTA","DEBORA","CHERIE","POLLY","DINA","JEWELL","FAY","JILLIAN","DOROTHEA","NELL","TRUDY","ESPERANZA","PATRICA","KIMBERLEY","SHANNA","HELENA","CAROLINA","CLEO","STEFANIE","ROSARIO","OLA","JANINE","MOLLIE","LUPE","ALISA","LOU","MARIBEL","SUSANNE","BETTE","SUSANA","ELISE","CECILE","ISABELLE","LESLEY","JOCELYN","PAIGE","JONI","RACHELLE","LEOLA","DAPHNE","ALTA","ESTER","PETRA","GRACIELA","IMOGENE","JOLENE","KEISHA","LACEY","GLENNA","GABRIELA","KERI","URSULA","LIZZIE","KIRSTEN","SHANA","ADELINE","MAYRA","JAYNE","JACLYN","GRACIE","SONDRA","CARMELA","MARISA","ROSALIND","CHARITY","TONIA","BEATRIZ","MARISOL","CLARICE","JEANINE","SHEENA","ANGELINE","FRIEDA","LILY","ROBBIE","SHAUNA","MILLIE","CLAUDETTE","CATHLEEN","ANGELIA","GABRIELLE","AUTUMN","KATHARINE","SUMMER","JODIE","STACI","LEA","CHRISTI","JIMMIE","JUSTINE","ELMA","LUELLA","MARGRET","DOMINIQUE","SOCORRO","RENE","MARTINA","MARGO","MAVIS","CALLIE","BOBBI","MARITZA","LUCILE","LEANNE","JEANNINE","DEANA","AILEEN","LORIE","LADONNA","WILLA","MANUELA","GALE","SELMA","DOLLY","SYBIL","ABBY","LARA","DALE","IVY","DEE","WINNIE","MARCY","LUISA","JERI","MAGDALENA","OFELIA","MEAGAN","AUDRA","MATILDA","LEILA","CORNELIA","BIANCA","SIMONE","BETTYE","RANDI","VIRGIE","LATISHA","BARBRA","GEORGINA","ELIZA","LEANN","BRIDGETTE","RHODA","HALEY","ADELA","NOLA","BERNADINE","FLOSSIE","ILA","GRETA","RUTHIE","NELDA","MINERVA","LILLY","TERRIE","LETHA","HILARY","ESTELA","VALARIE","BRIANNA","ROSALYN","EARLINE","CATALINA","AVA","MIA","CLARISSA","LIDIA","CORRINE","ALEXANDRIA","CONCEPCION","TIA","SHARRON","RAE","DONA","ERICKA","JAMI","ELNORA","CHANDRA","LENORE","NEVA","MARYLOU","MELISA","TABATHA","SERENA","AVIS","ALLIE","SOFIA","JEANIE","ODESSA","NANNIE","HARRIETT","LORAINE","PENELOPE","MILAGROS","EMILIA","BENITA","ALLYSON","ASHLEE","TANIA","TOMMIE","ESMERALDA","KARINA","EVE","PEARLIE","ZELMA","MALINDA","NOREEN","TAMEKA","SAUNDRA","HILLARY","AMIE","ALTHEA","ROSALINDA","JORDAN","LILIA","ALANA","GAY","CLARE","ALEJANDRA","ELINOR","MICHAEL","LORRIE","JERRI","DARCY","EARNESTINE","CARMELLA","TAYLOR","NOEMI","MARCIE","LIZA","ANNABELLE","LOUISA","EARLENE","MALLORY","CARLENE","NITA","SELENA","TANISHA","KATY","JULIANNE","JOHN","LAKISHA","EDWINA","MARICELA","MARGERY","KENYA","DOLLIE","ROXIE","ROSLYN","KATHRINE","NANETTE","CHARMAINE","LAVONNE","ILENE","KRIS","TAMMI","SUZETTE","CORINE","KAYE","JERRY","MERLE","CHRYSTAL","LINA","DEANNE","LILIAN","JULIANA","ALINE","LUANN","KASEY","MARYANNE","EVANGELINE","COLETTE","MELVA","LAWANDA","YESENIA","NADIA","MADGE","KATHIE","EDDIE","OPHELIA","VALERIA","NONA","MITZI","MARI","GEORGETTE","CLAUDINE","FRAN","ALISSA","ROSEANN","LAKEISHA","SUSANNA","REVA","DEIDRE","CHASITY","SHEREE","CARLY","JAMES","ELVIA","ALYCE","DEIRDRE","GENA","BRIANA","ARACELI","KATELYN","ROSANNE","WENDI","TESSA","BERTA","MARVA","IMELDA","MARIETTA","MARCI","LEONOR","ARLINE","SASHA","MADELYN","JANNA","JULIETTE","DEENA","AURELIA","JOSEFA","AUGUSTA","LILIANA","YOUNG","CHRISTIAN","LESSIE","AMALIA","SAVANNAH","ANASTASIA","VILMA","NATALIA","ROSELLA","LYNNETTE","CORINA","ALFREDA","LEANNA","CAREY","AMPARO","COLEEN","TAMRA","AISHA","WILDA","KARYN","CHERRY","QUEEN","MAURA","MAI","EVANGELINA","ROSANNA","HALLIE","ERNA","ENID","MARIANA","LACY","JULIET","JACKLYN","FREIDA","MADELEINE","MARA","HESTER","CATHRYN","LELIA","CASANDRA","BRIDGETT","ANGELITA","JANNIE","DIONNE","ANNMARIE","KATINA","BERYL","PHOEBE","MILLICENT","KATHERYN","DIANN","CARISSA","MARYELLEN","LIZ","LAURI","HELGA","GILDA","ADRIAN","RHEA","MARQUITA","HOLLIE","TISHA","TAMERA","ANGELIQUE","FRANCESCA","BRITNEY","KAITLIN","LOLITA","FLORINE","ROWENA","REYNA","TWILA","FANNY","JANELL","INES","CONCETTA","BERTIE","ALBA","BRIGITTE","ALYSON","VONDA","PANSY","ELBA","NOELLE","LETITIA","KITTY","DEANN","BRANDIE","LOUELLA","LETA","FELECIA","SHARLENE","LESA","BEVERLEY","ROBERT","ISABELLA","HERMINIA","TERRA","CELINA","TORI","OCTAVIA","JADE","DENICE","GERMAINE","SIERRA","MICHELL","CORTNEY","NELLY","DORETHA","SYDNEY","DEIDRA","MONIKA","LASHONDA","JUDI","CHELSEY","ANTIONETTE","MARGOT","BOBBY","ADELAIDE","NAN","LEEANN","ELISHA","DESSIE","LIBBY","KATHI","GAYLA","LATANYA","MINA","MELLISA","KIMBERLEE","JASMIN","RENAE","ZELDA","ELDA","MA","JUSTINA","GUSSIE","EMILIE","CAMILLA","ABBIE","ROCIO","KAITLYN","JESSE","EDYTHE","ASHLEIGH","SELINA","LAKESHA","GERI","ALLENE","PAMALA","MICHAELA","DAYNA","CARYN","ROSALIA","SUN","JACQULINE","REBECA","MARYBETH","KRYSTLE","IOLA","DOTTIE","BENNIE","BELLE","AUBREY","GRISELDA","ERNESTINA","ELIDA","ADRIANNE","DEMETRIA","DELMA","CHONG","JAQUELINE","DESTINY","ARLEEN","VIRGINA","RETHA","FATIMA","TILLIE","ELEANORE","CARI","TREVA","BIRDIE","WILHELMINA","ROSALEE","MAURINE","LATRICE","YONG","JENA","TARYN","ELIA","DEBBY","MAUDIE","JEANNA","DELILAH","CATRINA","SHONDA","HORTENCIA","THEODORA","TERESITA","ROBBIN","DANETTE","MARYJANE","FREDDIE","DELPHINE","BRIANNE","NILDA","DANNA","CINDI","BESS","IONA","HANNA","ARIEL","WINONA","VIDA","ROSITA","MARIANNA","WILLIAM","RACHEAL","GUILLERMINA","ELOISA","CELESTINE","CAREN","MALISSA","LONA","CHANTEL","SHELLIE","MARISELA","LEORA","AGATHA","SOLEDAD","MIGDALIA","IVETTE","CHRISTEN","ATHENA","JANEL","CHLOE","VEDA","PATTIE","TESSIE","TERA","MARILYNN","LUCRETIA","KARRIE","DINAH","DANIELA","ALECIA","ADELINA","VERNICE","SHIELA","PORTIA","MERRY","LASHAWN","DEVON","DARA","TAWANA","OMA","VERDA","CHRISTIN","ALENE","ZELLA","SANDI","RAFAELA","MAYA","KIRA","CANDIDA","ALVINA","SUZAN","SHAYLA","LYN","LETTIE","ALVA","SAMATHA","ORALIA","MATILDE","MADONNA","LARISSA","VESTA","RENITA","INDIA","DELOIS","SHANDA","PHILLIS","LORRI","ERLINDA","CRUZ","CATHRINE","BARB","ZOE","ISABELL","IONE","GISELA","CHARLIE","VALENCIA","ROXANNA","MAYME","KISHA","ELLIE","MELLISSA","DORRIS","DALIA","BELLA","ANNETTA","ZOILA","RETA","REINA","LAURETTA","KYLIE","CHRISTAL","PILAR","CHARLA","ELISSA","TIFFANI","TANA","PAULINA","LEOTA","BREANNA","JAYME","CARMEL","VERNELL","TOMASA","MANDI","DOMINGA","SANTA","MELODIE","LURA","ALEXA","TAMELA","RYAN","MIRNA","KERRIE","VENUS","NOEL","FELICITA","CRISTY","CARMELITA","BERNIECE","ANNEMARIE","TIARA","ROSEANNE","MISSY","CORI","ROXANA","PRICILLA","KRISTAL","JUNG","ELYSE","HAYDEE","ALETHA","BETTINA","MARGE","GILLIAN","FILOMENA","CHARLES","ZENAIDA","HARRIETTE","CARIDAD","VADA","UNA","ARETHA","PEARLINE","MARJORY","MARCELA","FLOR","EVETTE","ELOUISE","ALINA","TRINIDAD","DAVID","DAMARIS","CATHARINE","CARROLL","BELVA","NAKIA","MARLENA","LUANNE","LORINE","KARON","DORENE","DANITA","BRENNA","TATIANA","SAMMIE","LOUANN","LOREN","JULIANNA","ANDRIA","PHILOMENA","LUCILA","LEONORA","DOVIE","ROMONA","MIMI","JACQUELIN","GAYE","TONJA","MISTI","JOE","GENE","CHASTITY","STACIA","ROXANN","MICAELA","NIKITA","MEI","VELDA","MARLYS","JOHNNA","AURA","LAVERN","IVONNE","HAYLEY","NICKI","MAJORIE","HERLINDA","GEORGE","ALPHA","YADIRA","PERLA","GREGORIA","DANIEL","ANTONETTE","SHELLI","MOZELLE","MARIAH","JOELLE","CORDELIA","JOSETTE","CHIQUITA","TRISTA","LOUIS","LAQUITA","GEORGIANA","CANDI","SHANON","LONNIE","HILDEGARD","CECIL","VALENTINA","STEPHANY","MAGDA","KAROL","GERRY","GABRIELLA","TIANA","ROMA","RICHELLE","RAY","PRINCESS","OLETA","JACQUE","IDELLA","ALAINA","SUZANNA","JOVITA","BLAIR","TOSHA","RAVEN","NEREIDA","MARLYN","KYLA","JOSEPH","DELFINA","TENA","STEPHENIE","SABINA","NATHALIE","MARCELLE","GERTIE","DARLEEN","THEA","SHARONDA","SHANTEL","BELEN","VENESSA","ROSALINA","ONA","GENOVEVA","COREY","CLEMENTINE","ROSALBA","RENATE","RENATA","MI","IVORY","GEORGIANNA","FLOY","DORCAS","ARIANA","TYRA","THEDA","MARIAM","JULI","JESICA","DONNIE","VIKKI","VERLA","ROSELYN","MELVINA","JANNETTE","GINNY","DEBRAH","CORRIE","ASIA","VIOLETA","MYRTIS","LATRICIA","COLLETTE","CHARLEEN","ANISSA","VIVIANA","TWYLA","PRECIOUS","NEDRA","LATONIA","LAN","HELLEN","FABIOLA","ANNAMARIE","ADELL","SHARYN","CHANTAL","NIKI","MAUD","LIZETTE","LINDY","KIA","KESHA","JEANA","DANELLE","CHARLINE","CHANEL","CARROL","VALORIE","LIA","DORTHA","CRISTAL","SUNNY","LEONE","LEILANI","GERRI","DEBI","ANDRA","KESHIA","IMA","EULALIA","EASTER","DULCE","NATIVIDAD","LINNIE","KAMI","GEORGIE","CATINA","BROOK","ALDA","WINNIFRED","SHARLA","RUTHANN","MEAGHAN","MAGDALENE","LISSETTE","ADELAIDA","VENITA","TRENA","SHIRLENE","SHAMEKA","ELIZEBETH","DIAN","SHANTA","MICKEY","LATOSHA","CARLOTTA","WINDY","SOON","ROSINA","MARIANN","LEISA","JONNIE","DAWNA","CATHIE","BILLY","ASTRID","SIDNEY","LAUREEN","JANEEN","HOLLI","FAWN","VICKEY","TERESSA","SHANTE","RUBYE","MARCELINA","CHANDA","CARY","TERESE","SCARLETT","MARTY","MARNIE","LULU","LISETTE","JENIFFER","ELENOR","DORINDA","DONITA","CARMAN","BERNITA","ALTAGRACIA","ALETA","ADRIANNA","ZORAIDA","RONNIE","NICOLA","LYNDSEY","KENDALL","JANINA","CHRISSY","AMI","STARLA","PHYLIS","PHUONG","KYRA","CHARISSE","BLANCH","SANJUANITA","RONA","NANCI","MARILEE","MARANDA","CORY","BRIGETTE","SANJUANA","MARITA","KASSANDRA","JOYCELYN","IRA","FELIPA","CHELSIE","BONNY","MIREYA","LORENZA","KYONG","ILEANA","CANDELARIA","TONY","TOBY","SHERIE","OK","MARK","LUCIE","LEATRICE","LAKESHIA","GERDA","EDIE","BAMBI","MARYLIN","LAVON","HORTENSE","GARNET","EVIE","TRESSA","SHAYNA","LAVINA","KYUNG","JEANETTA","SHERRILL","SHARA","PHYLISS","MITTIE","ANABEL","ALESIA","THUY","TAWANDA","RICHARD","JOANIE","TIFFANIE","LASHANDA","KARISSA","ENRIQUETA","DARIA","DANIELLA","CORINNA","ALANNA","ABBEY","ROXANE","ROSEANNA","MAGNOLIA","LIDA","KYLE","JOELLEN","ERA","CORAL","CARLEEN","TRESA","PEGGIE","NOVELLA","NILA","MAYBELLE","JENELLE","CARINA","NOVA","MELINA","MARQUERITE","MARGARETTE","JOSEPHINA","EVONNE","DEVIN","CINTHIA","ALBINA","TOYA","TAWNYA","SHERITA","SANTOS","MYRIAM","LIZABETH","LISE","KEELY","JENNI","GISELLE","CHERYLE","ARDITH","ARDIS","ALESHA","ADRIANE","SHAINA","LINNEA","KAROLYN","HONG","FLORIDA","FELISHA","DORI","DARCI","ARTIE","ARMIDA","ZOLA","XIOMARA","VERGIE","SHAMIKA","NENA","NANNETTE","MAXIE","LOVIE","JEANE","JAIMIE","INGE","FARRAH","ELAINA","CAITLYN","STARR","FELICITAS","CHERLY","CARYL","YOLONDA","YASMIN","TEENA","PRUDENCE","PENNIE","NYDIA","MACKENZIE","ORPHA","MARVEL","LIZBETH","LAURETTE","JERRIE","HERMELINDA","CAROLEE","TIERRA","MIRIAN","META","MELONY","KORI","JENNETTE","JAMILA","ENA","ANH","YOSHIKO","SUSANNAH","SALINA","RHIANNON","JOLEEN","CRISTINE","ASHTON","ARACELY","TOMEKA","SHALONDA","MARTI","LACIE","KALA","JADA","ILSE","HAILEY","BRITTANI","ZONA","SYBLE","SHERRYL","RANDY","NIDIA","MARLO","KANDICE","KANDI","DEB","DEAN","AMERICA","ALYCIA","TOMMY","RONNA","NORENE","MERCY","JOSE","INGEBORG","GIOVANNA","GEMMA","CHRISTEL","AUDRY","ZORA","VITA","VAN","TRISH","STEPHAINE","SHIRLEE","SHANIKA","MELONIE","MAZIE","JAZMIN","INGA","HOA","HETTIE","GERALYN","FONDA","ESTRELLA","ADELLA","SU","SARITA","RINA","MILISSA","MARIBETH","GOLDA","EVON","ETHELYN","ENEDINA","CHERISE","CHANA","VELVA","TAWANNA","SADE","MIRTA","LI","KARIE","JACINTA","ELNA","DAVINA","CIERRA","ASHLIE","ALBERTHA","TANESHA","STEPHANI","NELLE","MINDI","LU","LORINDA","LARUE","FLORENE","DEMETRA","DEDRA","CIARA","CHANTELLE","ASHLY","SUZY","ROSALVA","NOELIA","LYDA","LEATHA","KRYSTYNA","KRISTAN","KARRI","DARLINE","DARCIE","CINDA","CHEYENNE","CHERRIE","AWILDA","ALMEDA","ROLANDA","LANETTE","JERILYN","GISELE","EVALYN","CYNDI","CLETA","CARIN","ZINA","ZENA","VELIA","TANIKA","PAUL","CHARISSA","THOMAS","TALIA","MARGARETE","LAVONDA","KAYLEE","KATHLENE","JONNA","IRENA","ILONA","IDALIA","CANDIS","CANDANCE","BRANDEE","ANITRA","ALIDA","SIGRID","NICOLETTE","MARYJO","LINETTE","HEDWIG","CHRISTIANA","CASSIDY","ALEXIA","TRESSIE","MODESTA","LUPITA","LITA","GLADIS","EVELIA","DAVIDA","CHERRI","CECILY","ASHELY","ANNABEL","AGUSTINA","WANITA","SHIRLY","ROSAURA","HULDA","EUN","BAILEY","YETTA","VERONA","THOMASINA","SIBYL","SHANNAN","MECHELLE","LUE","LEANDRA","LANI","KYLEE","KANDY","JOLYNN","FERNE","EBONI","CORENE","ALYSIA","ZULA","NADA","MOIRA","LYNDSAY","LORRETTA","JUAN","JAMMIE","HORTENSIA","GAYNELL","CAMERON","ADRIA","VINA","VICENTA","TANGELA","STEPHINE","NORINE","NELLA","LIANA","LESLEE","KIMBERELY","ILIANA","GLORY","FELICA","EMOGENE","ELFRIEDE","EDEN","EARTHA","CARMA","BEA","OCIE","MARRY","LENNIE","KIARA","JACALYN","CARLOTA","ARIELLE","YU","STAR","OTILIA","KIRSTIN","KACEY","JOHNETTA","JOEY","JOETTA","JERALDINE","JAUNITA","ELANA","DORTHEA","CAMI","AMADA","ADELIA","VERNITA","TAMAR","SIOBHAN","RENEA","RASHIDA","OUIDA","ODELL","NILSA","MERYL","KRISTYN","JULIETA","DANICA","BREANNE","AUREA","ANGLEA","SHERRON","ODETTE","MALIA","LORELEI","LIN","LEESA","KENNA","KATHLYN","FIONA","CHARLETTE","SUZIE","SHANTELL","SABRA","RACQUEL","MYONG","MIRA","MARTINE","LUCIENNE","LAVADA","JULIANN","JOHNIE","ELVERA","DELPHIA","CLAIR","CHRISTIANE","CHAROLETTE","CARRI","AUGUSTINE","ASHA","ANGELLA","PAOLA","NINFA","LEDA","LAI","EDA","SUNSHINE","STEFANI","SHANELL","PALMA","MACHELLE","LISSA","KECIA","KATHRYNE","KARLENE","JULISSA","JETTIE","JENNIFFER","HUI","CORRINA","CHRISTOPHER","CAROLANN","ALENA","TESS","ROSARIA","MYRTICE","MARYLEE","LIANE","KENYATTA","JUDIE","JANEY","IN","ELMIRA","ELDORA","DENNA","CRISTI","CATHI","ZAIDA","VONNIE","VIVA","VERNIE","ROSALINE","MARIELA","LUCIANA","LESLI","KARAN","FELICE","DENEEN","ADINA","WYNONA","TARSHA","SHERON","SHASTA","SHANITA","SHANI","SHANDRA","RANDA","PINKIE","PARIS","NELIDA","MARILOU","LYLA","LAURENE","LACI","JOI","JANENE","DOROTHA","DANIELE","DANI","CAROLYNN","CARLYN","BERENICE","AYESHA","ANNELIESE","ALETHEA","THERSA","TAMIKO","RUFINA","OLIVA","MOZELL","MARYLYN","MADISON","KRISTIAN","KATHYRN","KASANDRA","KANDACE","JANAE","GABRIEL","DOMENICA","DEBBRA","DANNIELLE","CHUN","BUFFY","BARBIE","ARCELIA","AJA","ZENOBIA","SHAREN","SHAREE","PATRICK","PAGE","MY","LAVINIA","KUM","KACIE","JACKELINE","HUONG","FELISA","EMELIA","ELEANORA","CYTHIA","CRISTIN","CLYDE","CLARIBEL","CARON","ANASTACIA","ZULMA","ZANDRA","YOKO","TENISHA","SUSANN","SHERILYN","SHAY","SHAWANDA","SABINE","ROMANA","MATHILDA","LINSEY","KEIKO","JOANA","ISELA","GRETTA","GEORGETTA","EUGENIE","DUSTY","DESIRAE","DELORA","CORAZON","ANTONINA","ANIKA","WILLENE","TRACEE","TAMATHA","REGAN","NICHELLE","MICKIE","MAEGAN","LUANA","LANITA","KELSIE","EDELMIRA","BREE","AFTON","TEODORA","TAMIE","SHENA","MEG","LINH","KELI","KACI","DANYELLE","BRITT","ARLETTE","ALBERTINE","ADELLE","TIFFINY","STORMY","SIMONA","NUMBERS","NICOLASA","NICHOL","NIA","NAKISHA","MEE","MAIRA","LOREEN","KIZZY","JOHNNY","JAY","FALLON","CHRISTENE","BOBBYE","ANTHONY","YING","VINCENZA","TANJA","RUBIE","RONI","QUEENIE","MARGARETT","KIMBERLI","IRMGARD","IDELL","HILMA","EVELINA","ESTA","EMILEE","DENNISE","DANIA","CARL","CARIE","ANTONIO","WAI","SANG","RISA","RIKKI","PARTICIA","MUI","MASAKO","MARIO","LUVENIA","LOREE","LONI","LIEN","KEVIN","GIGI","FLORENCIA","DORIAN","DENITA","DALLAS","CHI","BILLYE","ALEXANDER","TOMIKA","SHARITA","RANA","NIKOLE","NEOMA","MARGARITE","MADALYN","LUCINA","LAILA","KALI","JENETTE","GABRIELE","EVELYNE","ELENORA","CLEMENTINA","ALEJANDRINA","ZULEMA","VIOLETTE","VANNESSA","THRESA","RETTA","PIA","PATIENCE","NOELLA","NICKIE","JONELL","DELTA","CHUNG","CHAYA","CAMELIA","BETHEL","ANYA","ANDREW","THANH","SUZANN","SPRING","SHU","MILA","LILLA","LAVERNA","KEESHA","KATTIE","GIA","GEORGENE","EVELINE","ESTELL","ELIZBETH","VIVIENNE","VALLIE","TRUDIE","STEPHANE","MICHEL","MAGALY","MADIE","KENYETTA","KARREN","JANETTA","HERMINE","HARMONY","DRUCILLA","DEBBI","CELESTINA","CANDIE","BRITNI","BECKIE","AMINA","ZITA","YUN","YOLANDE","VIVIEN","VERNETTA","TRUDI","SOMMER","PEARLE","PATRINA","OSSIE","NICOLLE","LOYCE","LETTY","LARISA","KATHARINA","JOSELYN","JONELLE","JENELL","IESHA","HEIDE","FLORINDA","FLORENTINA","FLO","ELODIA","DORINE","BRUNILDA","BRIGID","ASHLI","ARDELLA","TWANA","THU","TARAH","SUNG","SHEA","SHAVON","SHANE","SERINA","RAYNA","RAMONITA","NGA","MARGURITE","LUCRECIA","KOURTNEY","KATI","JESUS","JESENIA","DIAMOND","CRISTA","AYANA","ALICA","ALIA","VINNIE","SUELLEN","ROMELIA","RACHELL","PIPER","OLYMPIA","MICHIKO","KATHALEEN","JOLIE","JESSI","JANESSA","HANA","HA","ELEASE","CARLETTA","BRITANY","SHONA","SALOME","ROSAMOND","REGENA","RAINA","NGOC","NELIA","LOUVENIA","LESIA","LATRINA","LATICIA","LARHONDA","JINA","JACKI","HOLLIS","HOLLEY","EMMY","DEEANN","CORETTA","ARNETTA","VELVET","THALIA","SHANICE","NETA","MIKKI","MICKI","LONNA","LEANA","LASHUNDA","KILEY","JOYE","JACQULYN","IGNACIA","HYUN","HIROKO","HENRY","HENRIETTE","ELAYNE","DELINDA","DARNELL","DAHLIA","COREEN","CONSUELA","CONCHITA","CELINE","BABETTE","AYANNA","ANETTE","ALBERTINA","SKYE","SHAWNEE","SHANEKA","QUIANA","PAMELIA","MIN","MERRI","MERLENE","MARGIT","KIESHA","KIERA","KAYLENE","JODEE","JENISE","ERLENE","EMMIE","ELSE","DARYL","DALILA","DAISEY","CODY","CASIE","BELIA","BABARA","VERSIE","VANESA","SHELBA","SHAWNDA","SAM","NORMAN","NIKIA","NAOMA","MARNA","MARGERET","MADALINE","LAWANA","KINDRA","JUTTA","JAZMINE","JANETT","HANNELORE","GLENDORA","GERTRUD","GARNETT","FREEDA","FREDERICA","FLORANCE","FLAVIA","DENNIS","CARLINE","BEVERLEE","ANJANETTE","VALDA","TRINITY","TAMALA","STEVIE","SHONNA","SHA","SARINA","ONEIDA","MICAH","MERILYN","MARLEEN","LURLINE","LENNA","KATHERIN","JIN","JENI","HAE","GRACIA","GLADY","FARAH","ERIC","ENOLA","EMA","DOMINQUE","DEVONA","DELANA","CECILA","CAPRICE","ALYSHA","ALI","ALETHIA","VENA","THERESIA","TAWNY","SONG","SHAKIRA","SAMARA","SACHIKO","RACHELE","PAMELLA","NICKY","MARNI","MARIEL","MAREN","MALISA","LIGIA","LERA","LATORIA","LARAE","KIMBER","KATHERN","KAREY","JENNEFER","JANETH","HALINA","FREDIA","DELISA","DEBROAH","CIERA","CHIN","ANGELIKA","ANDREE","ALTHA","YEN","VIVAN","TERRESA","TANNA","SUK","SUDIE","SOO","SIGNE","SALENA","RONNI","REBBECCA","MYRTIE","MCKENZIE","MALIKA","MAIDA","LOAN","LEONARDA","KAYLEIGH","FRANCE","ETHYL","ELLYN","DAYLE","CAMMIE","BRITTNI","BIRGIT","AVELINA","ASUNCION","ARIANNA","AKIKO","VENICE","TYESHA","TONIE","TIESHA","TAKISHA","STEFFANIE","SINDY","SANTANA","MEGHANN","MANDA","MACIE","LADY","KELLYE","KELLEE","JOSLYN","JASON","INGER","INDIRA","GLINDA","GLENNIS","FERNANDA","FAUSTINA","ENEIDA","ELICIA","DOT","DIGNA","DELL","ARLETTA","ANDRE","WILLIA","TAMMARA","TABETHA","SHERRELL","SARI","REFUGIO","REBBECA","PAULETTA","NIEVES","NATOSHA","NAKITA","MAMMIE","KENISHA","KAZUKO","KASSIE","GARY","EARLEAN","DAPHINE","CORLISS","CLOTILDE","CAROLYNE","BERNETTA","AUGUSTINA","AUDREA","ANNIS","ANNABELL","YAN","TENNILLE","TAMICA","SELENE","SEAN","ROSANA","REGENIA","QIANA","MARKITA","MACY","LEEANNE","LAURINE","KYM","JESSENIA","JANITA","GEORGINE","GENIE","EMIKO","ELVIE","DEANDRA","DAGMAR","CORIE","COLLEN","CHERISH","ROMAINE","PORSHA","PEARLENE","MICHELINE","MERNA","MARGORIE","MARGARETTA","LORE","KENNETH","JENINE","HERMINA","FREDERICKA","ELKE","DRUSILLA","DORATHY","DIONE","DESIRE","CELENA","BRIGIDA","ANGELES","ALLEGRA","THEO","TAMEKIA","SYNTHIA","STEPHEN","SOOK","SLYVIA","ROSANN","REATHA","RAYE","MARQUETTA","MARGART","LING","LAYLA","KYMBERLY","KIANA","KAYLEEN","KATLYN","KARMEN","JOELLA","IRINA","EMELDA","ELENI","DETRA","CLEMMIE","CHERYLL","CHANTELL","CATHEY","ARNITA","ARLA","ANGLE","ANGELIC","ALYSE","ZOFIA","THOMASINE","TENNIE","SON","SHERLY","SHERLEY","SHARYL","REMEDIOS","PETRINA","NICKOLE","MYUNG","MYRLE","MOZELLA","LOUANNE","LISHA","LATIA","LANE","KRYSTA","JULIENNE","JOEL","JEANENE","JACQUALINE","ISAURA","GWENDA","EARLEEN","DONALD","CLEOPATRA","CARLIE","AUDIE","ANTONIETTA","ALISE","ALEX","VERDELL","VAL","TYLER","TOMOKO","THAO","TALISHA","STEVEN","SO","SHEMIKA","SHAUN","SCARLET","SAVANNA","SANTINA","ROSIA","RAEANN","ODILIA","NANA","MINNA","MAGAN","LYNELLE","LE","KARMA","JOEANN","IVANA","INELL","ILANA","HYE","HONEY","HEE","GUDRUN","FRANK","DREAMA","CRISSY","CHANTE","CARMELINA","ARVILLA","ARTHUR","ANNAMAE","ALVERA","ALEIDA","AARON","YEE","YANIRA","VANDA","TIANNA","TAM","STEFANIA","SHIRA","PERRY","NICOL","NANCIE","MONSERRATE","MINH","MELYNDA","MELANY","MATTHEW","LOVELLA","LAURE","KIRBY","KACY","JACQUELYNN","HYON","GERTHA","FRANCISCO","ELIANA","CHRISTENA","CHRISTEEN","CHARISE","CATERINA","CARLEY","CANDYCE","ARLENA","AMMIE","YANG","WILLETTE","VANITA","TUYET","TINY","SYREETA","SILVA","SCOTT","RONALD","PENNEY","NYLA","MICHAL","MAURICE","MARYAM","MARYA","MAGEN","LUDIE","LOMA","LIVIA","LANELL","KIMBERLIE","JULEE","DONETTA","DIEDRA","DENISHA","DEANE","DAWNE","CLARINE","CHERRYL","BRONWYN","BRANDON","ALLA","VALERY","TONDA","SUEANN","SORAYA","SHOSHANA","SHELA","SHARLEEN","SHANELLE","NERISSA","MICHEAL","MERIDITH","MELLIE","MAYE","MAPLE","MAGARET","LUIS","LILI","LEONILA","LEONIE","LEEANNA","LAVONIA","LAVERA","KRISTEL","KATHEY","KATHE","JUSTIN","JULIAN","JIMMY","JANN","ILDA","HILDRED","HILDEGARDE","GENIA","FUMIKO","EVELIN","ERMELINDA","ELLY","DUNG","DOLORIS","DIONNA","DANAE","BERNEICE","ANNICE","ALIX","VERENA","VERDIE","TRISTAN","SHAWNNA","SHAWANA","SHAUNNA","ROZELLA","RANDEE","RANAE","MILAGRO","LYNELL","LUISE","LOUIE","LOIDA","LISBETH","KARLEEN","JUNITA","JONA","ISIS","HYACINTH","HEDY","GWENN","ETHELENE","ERLINE","EDWARD","DONYA","DOMONIQUE","DELICIA","DANNETTE","CICELY","BRANDA","BLYTHE","BETHANN","ASHLYN","ANNALEE","ALLINE","YUKO","VELLA","TRANG","TOWANDA","TESHA","SHERLYN","NARCISA","MIGUELINA","MERI","MAYBELL","MARLANA","MARGUERITA","MADLYN","LUNA","LORY","LORIANN","LIBERTY","LEONORE","LEIGHANN","LAURICE","LATESHA","LARONDA","KATRICE","KASIE","KARL","KALEY","JADWIGA","GLENNIE","GEARLDINE","FRANCINA","EPIFANIA","DYAN","DORIE","DIEDRE","DENESE","DEMETRICE","DELENA","DARBY","CRISTIE","CLEORA","CATARINA","CARISA","BERNIE","BARBERA","ALMETA","TRULA","TEREASA","SOLANGE","SHEILAH","SHAVONNE","SANORA","ROCHELL","MATHILDE","MARGARETA","MAIA","LYNSEY","LAWANNA","LAUNA","KENA","KEENA","KATIA","JAMEY","GLYNDA","GAYLENE","ELVINA","ELANOR","DANUTA","DANIKA","CRISTEN","CORDIE","COLETTA","CLARITA","CARMON","BRYNN","AZUCENA","AUNDREA","ANGELE","YI","WALTER","VERLIE","VERLENE","TAMESHA","SILVANA","SEBRINA","SAMIRA","REDA","RAYLENE","PENNI","PANDORA","NORAH","NOMA","MIREILLE","MELISSIA","MARYALICE","LARAINE","KIMBERY","KARYL","KARINE","KAM","JOLANDA","JOHANA","JESUSA","JALEESA","JAE","JACQUELYNE","IRISH","ILUMINADA","HILARIA","HANH","GENNIE","FRANCIE","FLORETTA","EXIE","EDDA","DREMA","DELPHA","BEV","BARBAR","ASSUNTA","ARDELL","ANNALISA","ALISIA","YUKIKO","YOLANDO","WONDA","WEI","WALTRAUD","VETA","TEQUILA","TEMEKA","TAMEIKA","SHIRLEEN","SHENITA","PIEDAD","OZELLA","MIRTHA","MARILU","KIMIKO","JULIANE","JENICE","JEN","JANAY","JACQUILINE","HILDE","FE","FAE","EVAN","EUGENE","ELOIS","ECHO","DEVORAH","CHAU","BRINDA","BETSEY","ARMINDA","ARACELIS","APRYL","ANNETT","ALISHIA","VEOLA","USHA","TOSHIKO","THEOLA","TASHIA","TALITHA","SHERY","RUDY","RENETTA","REIKO","RASHEEDA","OMEGA","OBDULIA","MIKA","MELAINE","MEGGAN","MARTIN","MARLEN","MARGET","MARCELINE","MANA","MAGDALEN","LIBRADA","LEZLIE","LEXIE","LATASHIA","LASANDRA","KELLE","ISIDRA","ISA","INOCENCIA","GWYN","FRANCOISE","ERMINIA","ERINN","DIMPLE","DEVORA","CRISELDA","ARMANDA","ARIE","ARIANE","ANGELO","ANGELENA","ALLEN","ALIZA","ADRIENE","ADALINE","XOCHITL","TWANNA","TRAN","TOMIKO","TAMISHA","TAISHA","SUSY","SIU","RUTHA","ROXY","RHONA","RAYMOND","OTHA","NORIKO","NATASHIA","MERRIE","MELVIN","MARINDA","MARIKO","MARGERT","LORIS","LIZZETTE","LEISHA","KAILA","KA","JOANNIE","JERRICA","JENE","JANNET","JANEE","JACINDA","HERTA","ELENORE","DORETTA","DELAINE","DANIELL","CLAUDIE","CHINA","BRITTA","APOLONIA","AMBERLY","ALEASE","YURI","YUK","WEN","WANETA","UTE","TOMI","SHARRI","SANDIE","ROSELLE","REYNALDA","RAGUEL","PHYLICIA","PATRIA","OLIMPIA","ODELIA","MITZIE","MITCHELL","MISS","MINDA","MIGNON","MICA","MENDY","MARIVEL","MAILE","LYNETTA","LAVETTE","LAURYN","LATRISHA","LAKIESHA","KIERSTEN","KARY","JOSPHINE","JOLYN","JETTA","JANISE","JACQUIE","IVELISSE","GLYNIS","GIANNA","GAYNELLE","EMERALD","DEMETRIUS","DANYELL","DANILLE","DACIA","CORALEE","CHER","CEOLA","BRETT","BELL","ARIANNE","ALESHIA","YUNG","WILLIEMAE","TROY","TRINH","THORA","TAI","SVETLANA","SHERIKA","SHEMEKA","SHAUNDA","ROSELINE","RICKI","MELDA","MALLIE","LAVONNA","LATINA","LARRY","LAQUANDA","LALA","LACHELLE","KLARA","KANDIS","JOHNA","JEANMARIE","JAYE","HANG","GRAYCE","GERTUDE","EMERITA","EBONIE","CLORINDA","CHING","CHERY","CAROLA","BREANN","BLOSSOM","BERNARDINE","BECKI","ARLETHA","ARGELIA","ARA","ALITA","YULANDA","YON","YESSENIA","TOBI","TASIA","SYLVIE","SHIRL","SHIRELY","SHERIDAN","SHELLA","SHANTELLE","SACHA","ROYCE","REBECKA","REAGAN","PROVIDENCIA","PAULENE","MISHA","MIKI","MARLINE","MARICA","LORITA","LATOYIA","LASONYA","KERSTIN","KENDA","KEITHA","KATHRIN","JAYMIE","JACK","GRICELDA","GINETTE","ERYN","ELINA","ELFRIEDA","DANYEL","CHEREE","CHANELLE","BARRIE","AVERY","AURORE","ANNAMARIA","ALLEEN","AILENE","AIDE","YASMINE","VASHTI","VALENTINE","TREASA","TORY","TIFFANEY","SHERYLL","SHARIE","SHANAE","SAU","RAISA","PA","NEDA","MITSUKO","MIRELLA","MILDA","MARYANNA","MARAGRET","MABELLE","LUETTA","LORINA","LETISHA","LATARSHA","LANELLE","LAJUANA","KRISSY","KARLY","KARENA","JON","JESSIKA","JERICA","JEANELLE","JANUARY","JALISA","JACELYN","IZOLA","IVEY","GREGORY","EUNA","ETHA","DREW","DOMITILA","DOMINICA","DAINA","CREOLA","CARLI","CAMIE","BUNNY","BRITTNY","ASHANTI","ANISHA","ALEEN","ADAH","YASUKO","WINTER","VIKI","VALRIE","TONA","TINISHA","THI","TERISA","TATUM","TANEKA","SIMONNE","SHALANDA","SERITA","RESSIE","REFUGIA","PAZ","OLENE","NA","MERRILL","MARGHERITA","MANDIE","MAN","MAIRE","LYNDIA","LUCI","LORRIANE","LORETA","LEONIA","LAVONA","LASHAWNDA","LAKIA","KYOKO","KRYSTINA","KRYSTEN","KENIA","KELSI","JUDE","JEANICE","ISOBEL","GEORGIANN","GENNY","FELICIDAD","EILENE","DEON","DELOISE","DEEDEE","DANNIE","CONCEPTION","CLORA","CHERILYN","CHANG","CALANDRA","BERRY","ARMANDINA","ANISA","ULA","TIMOTHY","TIERA","THERESSA","STEPHANIA","SIMA","SHYLA","SHONTA","SHERA","SHAQUITA","SHALA","SAMMY","ROSSANA","NOHEMI","NERY","MORIAH","MELITA","MELIDA","MELANI","MARYLYNN","MARISHA","MARIETTE","MALORIE","MADELENE","LUDIVINA","LORIA","LORETTE","LORALEE","LIANNE","LEON","LAVENIA","LAURINDA","LASHON","KIT","KIMI","KEILA","KATELYNN","KAI","JONE","JOANE","JI","JAYNA","JANELLA","JA","HUE","HERTHA","FRANCENE","ELINORE","DESPINA","DELSIE","DEEDRA","CLEMENCIA","CARRY","CAROLIN","CARLOS","BULAH","BRITTANIE","BOK","BLONDELL","BIBI","BEAULAH","BEATA","ANNITA","AGRIPINA","VIRGEN","VALENE","UN","TWANDA","TOMMYE","TOI","TARRA","TARI","TAMMERA","SHAKIA","SADYE","RUTHANNE","ROCHEL","RIVKA","PURA","NENITA","NATISHA","MING","MERRILEE","MELODEE","MARVIS","LUCILLA","LEENA","LAVETA","LARITA","LANIE","KEREN","ILEEN","GEORGEANN","GENNA","GENESIS","FRIDA","EWA","EUFEMIA","EMELY","ELA","EDYTH","DEONNA","DEADRA","DARLENA","CHANELL","CHAN","CATHERN","CASSONDRA","CASSAUNDRA","BERNARDA","BERNA","ARLINDA","ANAMARIA","ALBERT","WESLEY","VERTIE","VALERI","TORRI","TATYANA","STASIA","SHERISE","SHERILL","SEASON","SCOTTIE","SANDA","RUTHE","ROSY","ROBERTO","ROBBI","RANEE","QUYEN","PEARLY","PALMIRA","ONITA","NISHA","NIESHA","NIDA","NEVADA","NAM","MERLYN","MAYOLA","MARYLOUISE","MARYLAND","MARX","MARTH","MARGENE","MADELAINE","LONDA","LEONTINE","LEOMA","LEIA","LAWRENCE","LAURALEE","LANORA","LAKITA","KIYOKO","KETURAH","KATELIN","KAREEN","JONIE","JOHNETTE","JENEE","JEANETT","IZETTA","HIEDI","HEIKE","HASSIE","HAROLD","GIUSEPPINA","GEORGANN","FIDELA","FERNANDE","ELWANDA","ELLAMAE","ELIZ","DUSTI","DOTTY","CYNDY","CORALIE","CELESTA","ARGENTINA","ALVERTA","XENIA","WAVA","VANETTA","TORRIE","TASHINA","TANDY","TAMBRA","TAMA","STEPANIE","SHILA","SHAUNTA","SHARAN","SHANIQUA","SHAE","SETSUKO","SERAFINA","SANDEE","ROSAMARIA","PRISCILA","OLINDA","NADENE","MUOI","MICHELINA","MERCEDEZ","MARYROSE","MARIN","MARCENE","MAO","MAGALI","MAFALDA","LOGAN","LINN","LANNIE","KAYCE","KAROLINE","KAMILAH","KAMALA","JUSTA","JOLINE","JENNINE","JACQUETTA","IRAIDA","GERALD","GEORGEANNA","FRANCHESCA","FAIRY","EMELINE","ELANE","EHTEL","EARLIE","DULCIE","DALENE","CRIS","CLASSIE","CHERE","CHARIS","CAROYLN","CARMINA","CARITA","BRIAN","BETHANIE","AYAKO","ARICA","AN","ALYSA","ALESSANDRA","AKILAH","ADRIEN","ZETTA","YOULANDA","YELENA","YAHAIRA","XUAN","WENDOLYN","VICTOR","TIJUANA","TERRELL","TERINA","TERESIA","SUZI","SUNDAY","SHERELL","SHAVONDA","SHAUNTE","SHARDA","SHAKITA","SENA","RYANN","RUBI","RIVA","REGINIA","REA","RACHAL","PARTHENIA","PAMULA","MONNIE","MONET","MICHAELE","MELIA","MARINE","MALKA","MAISHA","LISANDRA","LEO","LEKISHA","LEAN","LAURENCE","LAKENDRA","KRYSTIN","KORTNEY","KIZZIE","KITTIE","KERA","KENDAL","KEMBERLY","KANISHA","JULENE","JULE","JOSHUA","JOHANNE","JEFFREY","JAMEE","HAN","HALLEY","GIDGET","GALINA","FREDRICKA","FLETA","FATIMAH","EUSEBIA","ELZA","ELEONORE","DORTHEY","DORIA","DONELLA","DINORAH","DELORSE","CLARETHA","CHRISTINIA","CHARLYN","BONG","BELKIS","AZZIE","ANDERA","AIKO","ADENA","YER","YAJAIRA","WAN","VANIA","ULRIKE","TOSHIA","TIFANY","STEFANY","SHIZUE","SHENIKA","SHAWANNA","SHAROLYN","SHARILYN","SHAQUANA","SHANTAY","SEE","ROZANNE","ROSELEE","RICKIE","REMONA","REANNA","RAELENE","QUINN","PHUNG","PETRONILA","NATACHA","NANCEY","MYRL","MIYOKO","MIESHA","MERIDETH","MARVELLA","MARQUITTA","MARHTA","MARCHELLE","LIZETH","LIBBIE","LAHOMA","LADAWN","KINA","KATHELEEN","KATHARYN","KARISA","KALEIGH","JUNIE","JULIEANN","JOHNSIE","JANEAN","JAIMEE","JACKQUELINE","HISAKO","HERMA","HELAINE","GWYNETH","GLENN","GITA","EUSTOLIA","EMELINA","ELIN","EDRIS","DONNETTE","DONNETTA","DIERDRE","DENAE","DARCEL","CLAUDE","CLARISA","CINDERELLA","CHIA","CHARLESETTA","CHARITA","CELSA","CASSY","CASSI","CARLEE","BRUNA","BRITTANEY","BRANDE","BILLI","BAO","ANTONETTA","ANGLA","ANGELYN","ANALISA","ALANE","WENONA","WENDIE","VERONIQUE","VANNESA","TOBIE","TEMPIE","SUMIKO","SULEMA","SPARKLE","SOMER","SHEBA","SHAYNE","SHARICE","SHANEL","SHALON","SAGE","ROY","ROSIO","ROSELIA","RENAY","REMA","REENA","PORSCHE","PING","PEG","OZIE","ORETHA","ORALEE","ODA","NU","NGAN","NAKESHA","MILLY","MARYBELLE","MARLIN","MARIS","MARGRETT","MARAGARET","MANIE","LURLENE","LILLIA","LIESELOTTE","LAVELLE","LASHAUNDA","LAKEESHA","KEITH","KAYCEE","KALYN","JOYA","JOETTE","JENAE","JANIECE","ILLA","GRISEL","GLAYDS","GENEVIE","GALA","FREDDA","FRED","ELMER","ELEONOR","DEBERA","DEANDREA","DAN","CORRINNE","CORDIA","CONTESSA","COLENE","CLEOTILDE","CHARLOTT","CHANTAY","CECILLE","BEATRIS","AZALEE","ARLEAN","ARDATH","ANJELICA","ANJA","ALFREDIA","ALEISHA","ADAM","ZADA","YUONNE","XIAO","WILLODEAN","WHITLEY","VENNIE","VANNA","TYISHA","TOVA","TORIE","TONISHA","TILDA","TIEN","TEMPLE","SIRENA","SHERRIL","SHANTI","SHAN","SENAIDA","SAMELLA","ROBBYN","RENDA","REITA","PHEBE","PAULITA","NOBUKO","NGUYET","NEOMI","MOON","MIKAELA","MELANIA","MAXIMINA","MARG","MAISIE","LYNNA","LILLI","LAYNE","LASHAUN","LAKENYA","LAEL","KIRSTIE","KATHLINE","KASHA","KARLYN","KARIMA","JOVAN","JOSEFINE","JENNELL","JACQUI","JACKELYN","HYO","HIEN","GRAZYNA","FLORRIE","FLORIA","ELEONORA","DWANA","DORLA","DONG","DELMY","DEJA","DEDE","DANN","CRYSTA","CLELIA","CLARIS","CLARENCE","CHIEKO","CHERLYN","CHERELLE","CHARMAIN","CHARA","CAMMY","BEE","ARNETTE","ARDELLE","ANNIKA","AMIEE","AMEE","ALLENA","YVONE","YUKI","YOSHIE","YEVETTE","YAEL","WILLETTA","VONCILE","VENETTA","TULA","TONETTE","TIMIKA","TEMIKA","TELMA","TEISHA","TAREN","TA","STACEE","SHIN","SHAWNTA","SATURNINA","RICARDA","POK","PASTY","ONIE","NUBIA","MORA","MIKE","MARIELLE","MARIELLA","MARIANELA","MARDELL","MANY","LUANNA","LOISE","LISABETH","LINDSY","LILLIANA","LILLIAM","LELAH","LEIGHA","LEANORA","LANG","KRISTEEN","KHALILAH","KEELEY","KANDRA","JUNKO","JOAQUINA","JERLENE","JANI","JAMIKA","JAME","HSIU","HERMILA","GOLDEN","GENEVIVE","EVIA","EUGENA","EMMALINE","ELFREDA","ELENE","DONETTE","DELCIE","DEEANNA","DARCEY","CUC","CLARINDA","CIRA","CHAE","CELINDA","CATHERYN","CATHERIN","CASIMIRA","CARMELIA","CAMELLIA","BREANA","BOBETTE","BERNARDINA","BEBE","BASILIA","ARLYNE","AMAL","ALAYNA","ZONIA","ZENIA","YURIKO","YAEKO","WYNELL","WILLOW","WILLENA","VERNIA","TU","TRAVIS","TORA","TERRILYN","TERICA","TENESHA","TAWNA","TAJUANA","TAINA","STEPHNIE","SONA","SOL","SINA","SHONDRA","SHIZUKO","SHERLENE","SHERICE","SHARIKA","ROSSIE","ROSENA","RORY","RIMA","RIA","RHEBA","RENNA","PETER","NATALYA","NANCEE","MELODI","MEDA","MAXIMA","MATHA","MARKETTA","MARICRUZ","MARCELENE","MALVINA","LUBA","LOUETTA","LEIDA","LECIA","LAURAN","LASHAWNA","LAINE","KHADIJAH","KATERINE","KASI","KALLIE","JULIETTA","JESUSITA","JESTINE","JESSIA","JEREMY","JEFFIE","JANYCE","ISADORA","GEORGIANNE","FIDELIA","EVITA","EURA","EULAH","ESTEFANA","ELSY","ELIZABET","ELADIA","DODIE","DION","DIA","DENISSE","DELORAS","DELILA","DAYSI","DAKOTA","CURTIS","CRYSTLE","CONCHA","COLBY","CLARETTA","CHU","CHRISTIA","CHARLSIE","CHARLENA","CARYLON","BETTYANN","ASLEY","ASHLEA","AMIRA","AI","AGUEDA","AGNUS","YUETTE","VINITA","VICTORINA","TYNISHA","TREENA","TOCCARA","TISH","THOMASENA","TEGAN","SOILA","SHILOH","SHENNA","SHARMAINE","SHANTAE","SHANDI","SEPTEMBER","SARAN","SARAI","SANA","SAMUEL","SALLEY","ROSETTE","ROLANDE","REGINE","OTELIA","OSCAR","OLEVIA","NICHOLLE","NECOLE","NAIDA","MYRTA","MYESHA","MITSUE","MINTA","MERTIE","MARGY","MAHALIA","MADALENE","LOVE","LOURA","LOREAN","LEWIS","LESHA","LEONIDA","LENITA","LAVONE","LASHELL","LASHANDRA","LAMONICA","KIMBRA","KATHERINA","KARRY","KANESHA","JULIO","JONG","JENEVA","JAQUELYN","HWA","GILMA","GHISLAINE","GERTRUDIS","FRANSISCA","FERMINA","ETTIE","ETSUKO","ELLIS","ELLAN","ELIDIA","EDRA","DORETHEA","DOREATHA","DENYSE","DENNY","DEETTA","DAINE","CYRSTAL","CORRIN","CAYLA","CARLITA","CAMILA","BURMA","BULA","BUENA","BLAKE","BARABARA","AVRIL","AUSTIN","ALAINE","ZANA","WILHEMINA","WANETTA","VIRGIL","VI","VERONIKA","VERNON","VERLINE","VASILIKI","TONITA","TISA","TEOFILA","TAYNA","TAUNYA","TANDRA","TAKAKO","SUNNI","SUANNE","SIXTA","SHARELL","SEEMA","RUSSELL","ROSENDA","ROBENA","RAYMONDE","PEI","PAMILA","OZELL","NEIDA","NEELY","MISTIE","MICHA","MERISSA","MAURITA","MARYLN","MARYETTA","MARSHALL","MARCELL","MALENA","MAKEDA","MADDIE","LOVETTA","LOURIE","LORRINE","LORILEE","LESTER","LAURENA","LASHAY","LARRAINE","LAREE","LACRESHA","KRISTLE","KRISHNA","KEVA","KEIRA","KAROLE","JOIE","JINNY","JEANNETTA","JAMA","HEIDY","GILBERTE","GEMA","FAVIOLA","EVELYNN","ENDA","ELLI","ELLENA","DIVINA","DAGNY","COLLENE","CODI","CINDIE","CHASSIDY","CHASIDY","CATRICE","CATHERINA","CASSEY","CAROLL","CARLENA","CANDRA","CALISTA","BRYANNA","BRITTENY","BEULA","BARI","AUDRIE","AUDRIA","ARDELIA","ANNELLE","ANGILA","ALONA","ALLYN","DOUGLAS","ROGER","JONATHAN","RALPH","NICHOLAS","BENJAMIN","BRUCE","HARRY","WAYNE","STEVE","HOWARD","ERNEST","PHILLIP","TODD","CRAIG","ALAN","PHILIP","EARL","DANNY","BRYAN","STANLEY","LEONARD","NATHAN","MANUEL","RODNEY","MARVIN","VINCENT","JEFFERY","JEFF","CHAD","JACOB","ALFRED","BRADLEY","HERBERT","FREDERICK","EDWIN","DON","RICKY","RANDALL","BARRY","BERNARD","LEROY","MARCUS","THEODORE","CLIFFORD","MIGUEL","JIM","TOM","CALVIN","BILL","LLOYD","DEREK","WARREN","DARRELL","JEROME","FLOYD","ALVIN","TIM","GORDON","GREG","JORGE","DUSTIN","PEDRO","DERRICK","ZACHARY","HERMAN","GLEN","HECTOR","RICARDO","RICK","BRENT","RAMON","GILBERT","MARC","REGINALD","RUBEN","NATHANIEL","RAFAEL","EDGAR","MILTON","RAUL","BEN","CHESTER","DUANE","FRANKLIN","BRAD","RON","ROLAND","ARNOLD","HARVEY","JARED","ERIK","DARRYL","NEIL","JAVIER","FERNANDO","CLINTON","TED","MATHEW","TYRONE","DARREN","LANCE","KURT","ALLAN","NELSON","GUY","CLAYTON","HUGH","MAX","DWAYNE","DWIGHT","ARMANDO","FELIX","EVERETT","IAN","WALLACE","KEN","BOB","ALFREDO","ALBERTO","DAVE","IVAN","BYRON","ISAAC","MORRIS","CLIFTON","WILLARD","ROSS","ANDY","SALVADOR","KIRK","SERGIO","SETH","KENT","TERRANCE","EDUARDO","TERRENCE","ENRIQUE","WADE","STUART","FREDRICK","ARTURO","ALEJANDRO","NICK","LUTHER","WENDELL","JEREMIAH","JULIUS","OTIS","TREVOR","OLIVER","LUKE","HOMER","GERARD","DOUG","KENNY","HUBERT","LYLE","MATT","ALFONSO","ORLANDO","REX","CARLTON","ERNESTO","NEAL","PABLO","LORENZO","OMAR","WILBUR","GRANT","HORACE","RODERICK","ABRAHAM","WILLIS","RICKEY","ANDRES","CESAR","JOHNATHAN","MALCOLM","RUDOLPH","DAMON","KELVIN","PRESTON","ALTON","ARCHIE","MARCO","WM","PETE","RANDOLPH","GARRY","GEOFFREY","JONATHON","FELIPE","GERARDO","ED","DOMINIC","DELBERT","COLIN","GUILLERMO","EARNEST","LUCAS","BENNY","SPENCER","RODOLFO","MYRON","EDMUND","GARRETT","SALVATORE","CEDRIC","LOWELL","GREGG","SHERMAN","WILSON","SYLVESTER","ROOSEVELT","ISRAEL","JERMAINE","FORREST","WILBERT","LELAND","SIMON","CLARK","IRVING","BRYANT","OWEN","RUFUS","WOODROW","KRISTOPHER","MACK","LEVI","MARCOS","GUSTAVO","JAKE","LIONEL","GILBERTO","CLINT","NICOLAS","ISMAEL","ORVILLE","ERVIN","DEWEY","AL","WILFRED","JOSH","HUGO","IGNACIO","CALEB","TOMAS","SHELDON","ERICK","STEWART","DOYLE","DARREL","ROGELIO","TERENCE","SANTIAGO","ALONZO","ELIAS","BERT","ELBERT","RAMIRO","CONRAD","NOAH","GRADY","PHIL","CORNELIUS","LAMAR","ROLANDO","CLAY","PERCY","DEXTER","BRADFORD","DARIN","AMOS","MOSES","IRVIN","SAUL","ROMAN","RANDAL","TIMMY","DARRIN","WINSTON","BRENDAN","ABEL","DOMINICK","BOYD","EMILIO","ELIJAH","DOMINGO","EMMETT","MARLON","EMANUEL","JERALD","EDMOND","EMIL","DEWAYNE","WILL","OTTO","TEDDY","REYNALDO","BRET","JESS","TRENT","HUMBERTO","EMMANUEL","STEPHAN","VICENTE","LAMONT","GARLAND","MILES","EFRAIN","HEATH","RODGER","HARLEY","ETHAN","ELDON","ROCKY","PIERRE","JUNIOR","FREDDY","ELI","BRYCE","ANTOINE","STERLING","CHASE","GROVER","ELTON","CLEVELAND","DYLAN","CHUCK","DAMIAN","REUBEN","STAN","AUGUST","LEONARDO","JASPER","RUSSEL","ERWIN","BENITO","HANS","MONTE","BLAINE","ERNIE","CURT","QUENTIN","AGUSTIN","MURRAY","JAMAL","ADOLFO","HARRISON","TYSON","BURTON","BRADY","ELLIOTT","WILFREDO","BART","JARROD","VANCE","DENIS","DAMIEN","JOAQUIN","HARLAN","DESMOND","ELLIOT","DARWIN","GREGORIO","BUDDY","XAVIER","KERMIT","ROSCOE","ESTEBAN","ANTON","SOLOMON","SCOTTY","NORBERT","ELVIN","WILLIAMS","NOLAN","ROD","QUINTON","HAL","BRAIN","ROB","ELWOOD","KENDRICK","DARIUS","MOISES","FIDEL","THADDEUS","CLIFF","MARCEL","JACKSON","RAPHAEL","BRYON","ARMAND","ALVARO","JEFFRY","DANE","JOESPH","THURMAN","NED","RUSTY","MONTY","FABIAN","REGGIE","MASON","GRAHAM","ISAIAH","VAUGHN","GUS","LOYD","DIEGO","ADOLPH","NORRIS","MILLARD","ROCCO","GONZALO","DERICK","RODRIGO","WILEY","RIGOBERTO","ALPHONSO","TY","NOE","VERN","REED","JEFFERSON","ELVIS","BERNARDO","MAURICIO","HIRAM","DONOVAN","BASIL","RILEY","NICKOLAS","MAYNARD","SCOT","VINCE","QUINCY","EDDY","SEBASTIAN","FEDERICO","ULYSSES","HERIBERTO","DONNELL","COLE","DAVIS","GAVIN","EMERY","WARD","ROMEO","JAYSON","DANTE","CLEMENT","COY","MAXWELL","JARVIS","BRUNO","ISSAC","DUDLEY","BROCK","SANFORD","CARMELO","BARNEY","NESTOR","STEFAN","DONNY","ART","LINWOOD","BEAU","WELDON","GALEN","ISIDRO","TRUMAN","DELMAR","JOHNATHON","SILAS","FREDERIC","DICK","IRWIN","MERLIN","CHARLEY","MARCELINO","HARRIS","CARLO","TRENTON","KURTIS","HUNTER","AURELIO","WINFRED","VITO","COLLIN","DENVER","CARTER","LEONEL","EMORY","PASQUALE","MOHAMMAD","MARIANO","DANIAL","LANDON","DIRK","BRANDEN","ADAN","BUFORD","GERMAN","WILMER","EMERSON","ZACHERY","FLETCHER","JACQUES","ERROL","DALTON","MONROE","JOSUE","EDWARDO","BOOKER","WILFORD","SONNY","SHELTON","CARSON","THERON","RAYMUNDO","DAREN","HOUSTON","ROBBY","LINCOLN","GENARO","BENNETT","OCTAVIO","CORNELL","HUNG","ARRON","ANTONY","HERSCHEL","GIOVANNI","GARTH","CYRUS","CYRIL","RONNY","LON","FREEMAN","DUNCAN","KENNITH","CARMINE","ERICH","CHADWICK","WILBURN","RUSS","REID","MYLES","ANDERSON","MORTON","JONAS","FOREST","MITCHEL","MERVIN","ZANE","RICH","JAMEL","LAZARO","ALPHONSE","RANDELL","MAJOR","JARRETT","BROOKS","ABDUL","LUCIANO","SEYMOUR","EUGENIO","MOHAMMED","VALENTIN","CHANCE","ARNULFO","LUCIEN","FERDINAND","THAD","EZRA","ALDO","RUBIN","ROYAL","MITCH","EARLE","ABE","WYATT","MARQUIS","LANNY","KAREEM","JAMAR","BORIS","ISIAH","EMILE","ELMO","ARON","LEOPOLDO","EVERETTE","JOSEF","ELOY","RODRICK","REINALDO","LUCIO","JERROD","WESTON","HERSHEL","BARTON","PARKER","LEMUEL","BURT","JULES","GIL","ELISEO","AHMAD","NIGEL","EFREN","ANTWAN","ALDEN","MARGARITO","COLEMAN","DINO","OSVALDO","LES","DEANDRE","NORMAND","KIETH","TREY","NORBERTO","NAPOLEON","JEROLD","FRITZ","ROSENDO","MILFORD","CHRISTOPER","ALFONZO","LYMAN","JOSIAH","BRANT","WILTON","RICO","JAMAAL","DEWITT","BRENTON","OLIN","FOSTER","FAUSTINO","CLAUDIO","JUDSON","GINO","EDGARDO","ALEC","TANNER","JARRED","DONN","TAD","PRINCE","PORFIRIO","ODIS","LENARD","CHAUNCEY","TOD","MEL","MARCELO","KORY","AUGUSTUS","KEVEN","HILARIO","BUD","SAL","ORVAL","MAURO","ZACHARIAH","OLEN","ANIBAL","MILO","JED","DILLON","AMADO","NEWTON","LENNY","RICHIE","HORACIO","BRICE","MOHAMED","DELMER","DARIO","REYES","MAC","JONAH","JERROLD","ROBT","HANK","RUPERT","ROLLAND","KENTON","DAMION","ANTONE","WALDO","FREDRIC","BRADLY","KIP","BURL","WALKER","TYREE","JEFFEREY","AHMED","WILLY","STANFORD","OREN","NOBLE","MOSHE","MIKEL","ENOCH","BRENDON","QUINTIN","JAMISON","FLORENCIO","DARRICK","TOBIAS","HASSAN","GIUSEPPE","DEMARCUS","CLETUS","TYRELL","LYNDON","KEENAN","WERNER","GERALDO","COLUMBUS","CHET","BERTRAM","MARKUS","HUEY","HILTON","DWAIN","DONTE","TYRON","OMER","ISAIAS","HIPOLITO","FERMIN","ADALBERTO","BO","BARRETT","TEODORO","MCKINLEY","MAXIMO","GARFIELD","RALEIGH","LAWERENCE","ABRAM","RASHAD","KING","EMMITT","DARON","SAMUAL","MIQUEL","EUSEBIO","DOMENIC","DARRON","BUSTER","WILBER","RENATO","JC","HOYT","HAYWOOD","EZEKIEL","CHAS","FLORENTINO","ELROY","CLEMENTE","ARDEN","NEVILLE","EDISON","DESHAWN","NATHANIAL","JORDON","DANILO","CLAUD","SHERWOOD","RAYMON","RAYFORD","CRISTOBAL","AMBROSE","TITUS","HYMAN","FELTON","EZEQUIEL","ERASMO","STANTON","LONNY","LEN","IKE","MILAN","LINO","JAROD","HERB","ANDREAS","WALTON","RHETT","PALMER","DOUGLASS","CORDELL","OSWALDO","ELLSWORTH","VIRGILIO","TONEY","NATHANAEL","DEL","BENEDICT","MOSE","JOHNSON","ISREAL","GARRET","FAUSTO","ASA","ARLEN","ZACK","WARNER","MODESTO","FRANCESCO","MANUAL","GAYLORD","GASTON","FILIBERTO","DEANGELO","MICHALE","GRANVILLE","WES","MALIK","ZACKARY","TUAN","ELDRIDGE","CRISTOPHER","CORTEZ","ANTIONE","MALCOM","LONG","KOREY","JOSPEH","COLTON","WAYLON","VON","HOSEA","SHAD","SANTO","RUDOLF","ROLF","REY","RENALDO","MARCELLUS","LUCIUS","KRISTOFER","BOYCE","BENTON","HAYDEN","HARLAND","ARNOLDO","RUEBEN","LEANDRO","KRAIG","JERRELL","JEROMY","HOBERT","CEDRICK","ARLIE","WINFORD","WALLY","LUIGI","KENETH","JACINTO","GRAIG","FRANKLYN","EDMUNDO","SID","PORTER","LEIF","JERAMY","BUCK","WILLIAN","VINCENZO","SHON","LYNWOOD","JERE","HAI","ELDEN","DORSEY","DARELL","BRODERICK","ALONSO" diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index bf913f60da..a309eb0ea1 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -7,7 +7,7 @@ USING: io io.files kernel math.parser namespaces sequences strings project-euler.009 project-euler.010 project-euler.011 project-euler.012 project-euler.013 project-euler.014 project-euler.015 project-euler.016 project-euler.017 project-euler.018 project-euler.019 project-euler.020 - project-euler.021 project-euler.067 ; + project-euler.021 project-euler.022 project-euler.067 ; IN: project-euler Date: Wed, 26 Dec 2007 09:06:52 -0500 Subject: [PATCH 29/67] Remove unnecessarily complicated PE022 solution --- extra/project-euler/022/022.factor | 29 +++++++---------------------- 1 file changed, 7 insertions(+), 22 deletions(-) diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index fb9930df67..1c8c8743f9 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -43,33 +43,18 @@ IN: project-euler.022 : alpha-value ( str -- n ) string>digits [ 9 - ] sigma ; -: name-score ( str seq -- n ) - over alpha-value -rot index 1+ * ; +: name-scores ( seq -- seq ) + dup length [ 1+ swap alpha-value * ] 2map ; PRIVATE> : euler022 ( -- answer ) - source-022 natural-sort dup [ over name-score ] sigma nip ; + source-022 natural-sort name-scores sum ; ! [ euler022 ] 100 ave-time -! 906 ms run / 1 ms GC ave time - 100 trials +! 59 ms run / 1 ms GC ave time - 100 trials -! source-022 [ natural-sort dup [ over name-score ] sigma nip ] curry 100 ave-time -! 850 ms run / 0 ms GC ave time - 100 trials +! source-022 [ natural-sort name-scores sum ] curry 100 ave-time +! 45 ms run / 1 ms GC ave time - 100 trials - -! ALTERNATE SOLUTIONS -! ------------------- - -! Take advantage of the names being ordered and eliminate calls to name-score - -: euler022a ( -- answer ) - source-022 natural-sort dup length [ 1+ swap alpha-value * ] 2map sum ; - -! [ euler022 ] 100 ave-time -! 60 ms run / 1 ms GC ave time - 100 trials - -! source-022 [ natural-sort dup length [ 1+ swap alpha-value * ] 2map sum ] curry 100 ave-time -! 47 ms run / 1 ms GC ave time - 100 trials - -MAIN: euler022a +MAIN: euler022 From aaa4b2a62f4aae6fe1759b11cf44e59db8eb2cd4 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 26 Dec 2007 20:35:35 +0100 Subject: [PATCH 30/67] Do not use Eratosthene sieve if n < 1e6 since we have a static primes list --- extra/math/erato/erato.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 4993f39e44..9b9ad53469 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: bit-arrays kernel lazy-lists math math.functions math.ranges sequences ; +USING: bit-arrays kernel lazy-lists math math.functions math.primes.list + math.ranges sequences ; IN: math.erato : lerato ( n -- lazy-list ) - 2 [ drop next-prime ] curry* lfrom-by [ ] lwhile ; + dup 1000003 < [ + 0 primes-under-million seq>list swap [ <= ] curry lwhile + ] [ + 2 [ drop next-prime ] curry* lfrom-by [ ] lwhile + ] if ; From 9f0fb715abc77220da2836cad17ab1615cf1e1d6 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 26 Dec 2007 21:44:22 +0100 Subject: [PATCH 31/67] Factor solution to project Euler problem 134 --- extra/project-euler/134/134.factor | 63 ++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) create mode 100644 extra/project-euler/134/134.factor diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor new file mode 100644 index 0000000000..9b623e7cb8 --- /dev/null +++ b/extra/project-euler/134/134.factor @@ -0,0 +1,63 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math math.functions math.ranges math.primes.list namespaces + sequences vars ; +IN: project-euler.134 + +! http://projecteuler.net/index.php?section=problems&id=134 + +! DESCRIPTION +! ----------- + +! Consider the consecutive primes p1 = 19 and p2 = 23. It can be +! verified that 1219 is the smallest number such that the last digits +! are formed by p1 whilst also being divisible by p2. + +! In fact, with the exception of p1 = 3 and p2 = 5, for every pair of +! consecutive primes, p2 p1, there exist values of n for which the last +! digits are formed by p1 and n is divisible by p2. Let S be the +! smallest of these values of n. + +! Find S for every pair of consecutive primes with 5 p1 1000000. + +! SOLUTION +! -------- + +integer [ 10 * ] times ; foldable + +! Helper variables and words for the extended Euclidian algorithm +! See http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm + +VARS: r-1 u-1 v-1 r u v ; + +: init ( a b -- ) + >r >r-1 0 >u 1 >u-1 1 >v 0 >v-1 ; + +: advance ( r u v -- ) + v> >v-1 >v u> >u-1 >u r> >r-1 >r ; + +: step ( -- ) + r-1> r> 2dup / >integer [ * - ] keep u-1> over u> * - v-1> rot v> * - + advance ; + +! Compute the inverse of a in field Z/bZ where b is prime +: inverse ( a b -- a-1 ) + [ init [ r> 0 > ] [ step ] [ ] while u-1> ] with-scope ; + +! Compute S for a given pair (p1, p2) +: s ( p1 p2 -- s ) + over next-power-of-10 [ over inverse pick * neg swap rem ] keep * + ; + +PRIVATE> + +: euler134 ( -- answer ) + primes-under-million 2 tail dup 1 tail 1000003 add [ s ] 2map sum ; + +! [ euler134 ] 10 ave-time +! 6743 ms run / 79 ms GC ave time - 10 trials + +MAIN: euler134 From c4529fb5574a8686c1670e2a632c28fe325413d9 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 26 Dec 2007 22:42:33 +0100 Subject: [PATCH 32/67] Add math.algebra module with some useful words. - ext-euclidian implements the extended Euclidian algorithm - ring-inverse computes an inverse in a Z/nZ ring - chinese-remainder solves a multi-constraints modular equation --- extra/math/algebra/algebra-docs.factor | 14 ++++++++++ extra/math/algebra/algebra-tests.factor | 5 ++++ extra/math/algebra/algebra.factor | 34 +++++++++++++++++++++++++ extra/math/algebra/authors.txt | 1 + extra/math/algebra/summary.txt | 1 + 5 files changed, 55 insertions(+) create mode 100644 extra/math/algebra/algebra-docs.factor create mode 100644 extra/math/algebra/algebra-tests.factor create mode 100644 extra/math/algebra/algebra.factor create mode 100644 extra/math/algebra/authors.txt create mode 100644 extra/math/algebra/summary.txt diff --git a/extra/math/algebra/algebra-docs.factor b/extra/math/algebra/algebra-docs.factor new file mode 100644 index 0000000000..14fdc9a505 --- /dev/null +++ b/extra/math/algebra/algebra-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ; +IN: math.algebra + +HELP: ext-euclidian +{ $values { "a" "a positive integer" } { "b" "a positive integer" } { "gcd" "a positive integer" } { "u" "an integer" } { "v" "an integer" } } +{ $description "Compute the greatest common divisor " { $snippet "gcd" } " of integers " { $snippet "a" } " and " { $snippet "b" } " using the extended Euclidian algorithm. In addition, this word also computes two other values " { $snippet "u" } " and " { $snippet "v" } " such that " { $snippet "a*u + b*v = gcd" } "." } ; + +HELP: ring-inverse +{ $values { "a" "a positive integer" } { "b" "a positive integer" } { "i" "a positive integer" } } +{ $description "If " { $snippet "a" } " and " { $snippet "b" } " are coprime, " { $snippet "i" } " is the smallest positive integer such as " { $snippet "a*i = 1" } " in ring " { $snippet "Z/bZ" } "." } ; + +HELP: chinese-remainder +{ $values { "aseq" "a sequence of integers" } { "nseq" "a sequence of positive integers" } { "x" "an integer" } } +{ $description "If " { $snippet "nseq" } " integers are pairwise coprimes, " { $snippet "x" } " is the smallest positive integer congruent to each element in " { $snippet "aseq" } " modulo the corresponding element in " { $snippet "nseq" } "." } ; diff --git a/extra/math/algebra/algebra-tests.factor b/extra/math/algebra/algebra-tests.factor new file mode 100644 index 0000000000..86b513aecd --- /dev/null +++ b/extra/math/algebra/algebra-tests.factor @@ -0,0 +1,5 @@ +USING: math.algebra tools.test ; + +{ 2 5 -2 } [ 10 24 ext-euclidian ] unit-test +{ 17 } [ 19 23 ring-inverse ] unit-test +{ 11 } [ { 2 3 1 } { 3 4 5 } chinese-remainder ] unit-test diff --git a/extra/math/algebra/algebra.factor b/extra/math/algebra/algebra.factor new file mode 100644 index 0000000000..6ba445b0b0 --- /dev/null +++ b/extra/math/algebra/algebra.factor @@ -0,0 +1,34 @@ +! Copyright (c) 2007 Samuel Tardieu +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.ranges namespaces sequences vars math.algebra ; +IN: math.algebra + +r >r-1 0 >u 1 >u-1 1 >v 0 >v-1 ; + +: advance ( r u v -- ) + v> >v-1 >v u> >u-1 >u r> >r-1 >r ; inline + +: step ( -- ) + r-1> r> 2dup /mod drop [ * - ] keep u-1> over u> * - v-1> rot v> * - + advance ; + +PRIVATE> + +! Extended Euclidian: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm +: ext-euclidian ( a b -- gcd u v ) + [ init [ r> 0 > ] [ step ] [ ] while r-1> u-1> v-1> ] with-scope ; foldable + +! Inverse a in ring Z/bZ +: ring-inverse ( a b -- i ) + [ ext-euclidian drop nip ] keep rem ; foldable + +! Chinese remainder: http://en.wikipedia.org/wiki/Chinese_remainder_theorem +: chinese-remainder ( aseq nseq -- x ) + dup product + [ [ over / [ ext-euclidian ] keep * 2nip * ] curry 2map sum ] keep rem ; + foldable diff --git a/extra/math/algebra/authors.txt b/extra/math/algebra/authors.txt new file mode 100644 index 0000000000..f3b0233f74 --- /dev/null +++ b/extra/math/algebra/authors.txt @@ -0,0 +1 @@ +Samuel Tardieu diff --git a/extra/math/algebra/summary.txt b/extra/math/algebra/summary.txt new file mode 100644 index 0000000000..5f0748e37a --- /dev/null +++ b/extra/math/algebra/summary.txt @@ -0,0 +1 @@ +Various algebra-related words From 4eb7aad50bd70a117873a5740d7df5146ae0d355 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 26 Dec 2007 23:08:43 +0100 Subject: [PATCH 33/67] Use math.algebra to solve project Euler problem 134 --- extra/project-euler/134/134.factor | 33 ++++++------------------------ 1 file changed, 6 insertions(+), 27 deletions(-) diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index 9b623e7cb8..b30b0073d2 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.functions math.ranges math.primes.list namespaces - sequences vars ; +USING: arrays kernel math.algebra math math.functions math.primes.list + math.ranges sequences ; IN: project-euler.134 ! http://projecteuler.net/index.php?section=problems&id=134 @@ -23,36 +23,15 @@ IN: project-euler.134 ! SOLUTION ! -------- -integer [ 10 * ] times ; foldable -! Helper variables and words for the extended Euclidian algorithm -! See http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm - -VARS: r-1 u-1 v-1 r u v ; - -: init ( a b -- ) - >r >r-1 0 >u 1 >u-1 1 >v 0 >v-1 ; - -: advance ( r u v -- ) - v> >v-1 >v u> >u-1 >u r> >r-1 >r ; - -: step ( -- ) - r-1> r> 2dup / >integer [ * - ] keep u-1> over u> * - v-1> rot v> * - - advance ; - -! Compute the inverse of a in field Z/bZ where b is prime -: inverse ( a b -- a-1 ) - [ init [ r> 0 > ] [ step ] [ ] while u-1> ] with-scope ; - -! Compute S for a given pair (p1, p2) +! Compute S for a given pair (p1, p2) -- that is the smallest positive +! number such that X = p1 [npt] and X = 0 [p2] (npt being the smallest +! power of 10 above p1) : s ( p1 p2 -- s ) - over next-power-of-10 [ over inverse pick * neg swap rem ] keep * + ; - -PRIVATE> + over 0 2array rot next-power-of-10 rot 2array chinese-remainder ; : euler134 ( -- answer ) primes-under-million 2 tail dup 1 tail 1000003 add [ s ] 2map sum ; From 0bf5c6bf0ff6edc0cffae4dcb22580ee255e261d Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 27 Dec 2007 03:36:38 +0100 Subject: [PATCH 34/67] Simplify lazy-while and lazy-until constructs --- extra/lazy-lists/lazy-lists.factor | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 1fb7a18cba..daf02eef22 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -211,17 +211,17 @@ TUPLE: lazy-until cons quot ; C: lazy-until : luntil ( list quot -- result ) - ; + over nil? [ drop ] [ ] if ; M: lazy-until car ( lazy-until -- car ) lazy-until-cons car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ lazy-until-cons uncons ] keep lazy-until-quot - rot over call [ 2drop nil ] [ luntil ] if ; + [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call + [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) - lazy-until-cons nil? ; + drop f ; M: lazy-until list? ( lazy-until -- bool ) drop t ; @@ -231,19 +231,16 @@ TUPLE: lazy-while cons quot ; C: lazy-while : lwhile ( list quot -- result ) - -; + over nil? [ drop ] [ ] if ; M: lazy-while car ( lazy-while -- car ) lazy-while-cons car ; M: lazy-while cdr ( lazy-while -- cdr ) - dup lazy-while-cons cdr dup nil? - [ 2drop nil ] [ swap lazy-while-quot lwhile ] if ; + [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ; M: lazy-while nil? ( lazy-while -- bool ) - dup lazy-while-cons nil? - [ nip ] [ [ car ] keep lazy-while-quot call not ] if* ; + [ car ] keep lazy-while-quot call not ; M: lazy-while list? ( lazy-while -- bool ) drop t ; From 76c76b81ed2c92b44ac0ac40a87418410a7df847 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 27 Dec 2007 03:42:19 +0100 Subject: [PATCH 35/67] Simplify lazy-append nil? word lazy-append tuples are always built using lappend. If list1 is nil, then list2 is returned, hence nil? on a lazy-append object is always false. --- extra/lazy-lists/lazy-lists.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index daf02eef22..c42daabc05 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -310,11 +310,7 @@ M: lazy-append cdr ( lazy-append -- cdr ) lazy-append-list2 lappend ; M: lazy-append nil? ( lazy-append -- bool ) - dup lazy-append-list1 nil? [ - lazy-append-list2 nil? - ] [ - drop f - ] if ; + drop f ; M: lazy-append list? ( object -- bool ) drop t ; From 3662ed8f0ba8e290b348577b5e289e1cb375004c Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 27 Dec 2007 15:17:21 +0100 Subject: [PATCH 36/67] Use s> and >s instead of r> and >r to avoid confusion --- extra/math/algebra/algebra.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/extra/math/algebra/algebra.factor b/extra/math/algebra/algebra.factor index 6ba445b0b0..0dfd086e70 100644 --- a/extra/math/algebra/algebra.factor +++ b/extra/math/algebra/algebra.factor @@ -1,27 +1,30 @@ ! Copyright (c) 2007 Samuel Tardieu ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.ranges namespaces sequences vars math.algebra ; +USING: kernel math math.ranges namespaces sequences vars ; IN: math.algebra " and ">r", so we chose to use "s" instead. + +VARS: s-1 u-1 v-1 s u v ; : init ( a b -- ) - >r >r-1 0 >u 1 >u-1 1 >v 0 >v-1 ; + >s >s-1 0 >u 1 >u-1 1 >v 0 >v-1 ; : advance ( r u v -- ) - v> >v-1 >v u> >u-1 >u r> >r-1 >r ; inline + v> >v-1 >v u> >u-1 >u s> >s-1 >s ; inline : step ( -- ) - r-1> r> 2dup /mod drop [ * - ] keep u-1> over u> * - v-1> rot v> * - + s-1> s> 2dup /mod drop [ * - ] keep u-1> over u> * - v-1> rot v> * - advance ; PRIVATE> ! Extended Euclidian: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm : ext-euclidian ( a b -- gcd u v ) - [ init [ r> 0 > ] [ step ] [ ] while r-1> u-1> v-1> ] with-scope ; foldable + [ init [ s> 0 > ] [ step ] [ ] while s-1> u-1> v-1> ] with-scope ; foldable ! Inverse a in ring Z/bZ : ring-inverse ( a b -- i ) From 779f1ba01db4da943db6c114de150820326232a4 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 27 Dec 2007 15:58:39 +0100 Subject: [PATCH 37/67] Use related-words in lazy-lists documentation --- extra/lazy-lists/lazy-lists-docs.factor | 97 ++++++++++--------------- 1 file changed, 38 insertions(+), 59 deletions(-) diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index b66eb6367f..f539e35835 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -4,70 +4,64 @@ USING: help.markup help.syntax sequences strings ; IN: lazy-lists +{ car cons cdr nil nil? list? uncons } related-words + HELP: cons { $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } -{ $description "Constructs a cons cell." } -{ $see-also cons car cdr nil nil? list? } ; +{ $description "Constructs a cons cell." } ; HELP: car { $values { "cons" "a cons object" } { "car" "the first item in the list" } } -{ $description "Returns the first item in the list." } -{ $see-also cons cdr nil nil? list? } ; +{ $description "Returns the first item in the list." } ; HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } -{ $description "Returns the tail of the list." } -{ $see-also cons car nil nil? list? } ; +{ $description "Returns the tail of the list." } ; HELP: nil { $values { "cons" "An empty cons" } } -{ $description "Returns a representation of an empty list" } -{ $see-also cons car cdr nil? list? } ; +{ $description "Returns a representation of an empty list" } ; HELP: nil? { $values { "cons" "a cons object" } { "?" "a boolean" } } -{ $description "Return true if the cons object is the nil cons." } -{ $see-also cons car cdr nil list? } ; +{ $description "Return true if the cons object is the nil cons." } ; HELP: list? { $values { "object" "an object" } { "?" "a boolean" } } -{ $description "Returns true if the object conforms to the list protocol." } -{ $see-also cons car cdr nil } ; +{ $description "Returns true if the object conforms to the list protocol." } ; + +{ 1list 2list 3list } related-words HELP: 1list { $values { "obj" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 1 element." } -{ $see-also 2list 3list } ; +{ $description "Create a list with 1 element." } ; HELP: 2list { $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 2 elements." } -{ $see-also 1list 3list } ; +{ $description "Create a list with 2 elements." } ; HELP: 3list { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 3 elements." } -{ $see-also 1list 2list } ; +{ $description "Create a list with 3 elements." } ; HELP: lazy-cons { $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } } { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } { $see-also cons car cdr nil nil? } ; +{ 1lazy-list 2lazy-list 3lazy-list } related-words + HELP: 1lazy-list { $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } } -{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } -{ $see-also 2lazy-list 3lazy-list } ; +{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ; HELP: 2lazy-list { $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } } -{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } -{ $see-also 1lazy-list 3lazy-list } ; +{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ; HELP: 3lazy-list { $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } } -{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } -{ $see-also 1lazy-list 2lazy-list } ; +{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ; HELP: { $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } } @@ -86,43 +80,37 @@ HELP: llength HELP: uncons { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } -{ $description "Put the head and tail of the list on the stack." } -{ $see-also cons car cdr } ; +{ $description "Put the head and tail of the list on the stack." } ; + +{ leach lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words HELP: leach { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } -{ $description "Call the quotation for each item in the list." } -{ $see-also lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Call the quotation for each item in the list." } ; HELP: lmap { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } } -{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } -{ $see-also leach ltake lsubset lappend lmap-with lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: lmap-with { $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } } -{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } -{ $see-also leach ltake lsubset lappend lmap lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ; HELP: ltake { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } -{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } -{ $see-also leach lmap lmap-with lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: lsubset { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } } -{ $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } -{ $see-also leach lmap lmap-with ltake lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: lwhile { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } } -{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } -{ $see-also luntil } ; +{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: luntil { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } } -{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } -{ $see-also lwhile } ; +{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: list>vector { $values { "list" "a cons object" } { "vector" "the list converted to a vector" } } @@ -136,18 +124,15 @@ HELP: list>array HELP: lappend { $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } } -{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } -{ $see-also leach lmap lmap-with ltake lsubset lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ; HELP: lfrom-by { $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } } -{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } -{ $see-also leach lmap lmap-with ltake lsubset lfrom lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ; HELP: lfrom { $values { "n" "an integer" } { "list" "a lazy list of integers" } } -{ $description "Return an infinite lazy list of incrementing integers starting from n." } -{ $see-also leach lmap lmap-with ltake lsubset lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Return an infinite lazy list of incrementing integers starting from n." } ; HELP: seq>list { $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } } @@ -161,39 +146,33 @@ HELP: >list HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } -{ $description "Concatenates a list of lists together into one list." } -{ $see-also leach lmap lmap-with ltake lsubset lcartesian-product lcartesian-product* lfrom-by lcomp lcomp* lmerge } ; +{ $description "Concatenates a list of lists together into one list." } ; HELP: lcartesian-product { $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } } -{ $description "Given two lists, return a list containing the cartesian product of those lists." } -{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product* lcomp lcomp* lmerge } ; +{ $description "Given two lists, return a list containing the cartesian product of those lists." } ; HELP: lcartesian-product* { $values { "lists" "a list of lists" } { "result" "list of cartesian products" } } -{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } -{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp lcomp* lmerge } ; +{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ; HELP: lcomp { $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } } -{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } -{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp* lmerge } ; +{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ; HELP: lcomp* { $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } } -{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." } +{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." } { $examples { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" } -} -{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp lmerge } ; +} ; HELP: lmerge { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } } { $description "Return the result of merging the two lists in a lazy manner." } { $examples { $example "USE: lazy-lists" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } -} -{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp } ; +} ; HELP: lcontents { $values { "stream" "a stream" } { "result" string } } From db6dbc5f161b5791d45e3d875456e97b90d808bf Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 27 Dec 2007 15:34:15 +0100 Subject: [PATCH 38/67] Implement lreduce in lazy-lists --- extra/lazy-lists/lazy-lists-docs.factor | 6 +++++- extra/lazy-lists/lazy-lists.factor | 3 +++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index f539e35835..11afc9b6b5 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -82,12 +82,16 @@ HELP: uncons { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; -{ leach lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words +{ leach lreduce lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words HELP: leach { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } { $description "Call the quotation for each item in the list." } ; +HELP: lreduce +{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } +{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; + HELP: lmap { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index c42daabc05..9f2e05c7ba 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -102,6 +102,9 @@ M: lazy-cons list? ( object -- bool ) : leach ( list quot -- ) swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline +: lreduce ( list identity quot -- result ) + swapd leach ; inline + TUPLE: memoized-cons original car cdr nil? ; : not-memoized ( -- obj ) From 694dd297ad19dc581886eaca3d832b6cee5d1f3d Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 27 Dec 2007 03:59:39 +0100 Subject: [PATCH 39/67] New module math.primes --- extra/math/primes/authors.txt | 1 + extra/math/primes/primes-docs.factor | 30 ++++++++++++++++ extra/math/primes/primes-tests.factor | 10 ++++++ extra/math/primes/primes.factor | 49 +++++++++++++++++++++++++++ extra/math/primes/summary.txt | 2 ++ 5 files changed, 92 insertions(+) create mode 100644 extra/math/primes/authors.txt create mode 100644 extra/math/primes/primes-docs.factor create mode 100644 extra/math/primes/primes-tests.factor create mode 100644 extra/math/primes/primes.factor create mode 100644 extra/math/primes/summary.txt diff --git a/extra/math/primes/authors.txt b/extra/math/primes/authors.txt new file mode 100644 index 0000000000..f3b0233f74 --- /dev/null +++ b/extra/math/primes/authors.txt @@ -0,0 +1 @@ +Samuel Tardieu diff --git a/extra/math/primes/primes-docs.factor b/extra/math/primes/primes-docs.factor new file mode 100644 index 0000000000..1077659d5e --- /dev/null +++ b/extra/math/primes/primes-docs.factor @@ -0,0 +1,30 @@ +USING: help.markup help.syntax ; +IN: math.primes + +{ next-prime prime? } related-words + +HELP: next-prime +{ $values { "n" "a positive integer" } { "p" "a prime number" } } +{ $description "Return the next prime number greater than " { $snippet "n" } "." } ; + +HELP: prime? +{ $values { "n" "an integer" } { "?" "a boolean" } } +{ $description "Test if an integer is a prime number." } ; + +{ lprimes lprimes-from primes-upto primes-between } related-words + +HELP: lprimes +{ $values { "list" "a lazy list" } } +{ $description "Return a sorted list containing all the prime numbers." } ; + +HELP: lprimes-from +{ $values { "n" "an integer" } { "list" "a lazy list" } } +{ $description "Return a sorted list containing all the prime numbers greater or equal to " { $snippet "n" } "." } ; + +HELP: primes-upto +{ $values { "n" "an integer" } { "seq" "a sequence" } } +{ $description "Return a sequence containing all the prime numbers smaller or equal to " { $snippet "n" } "." } ; + +HELP: primes-between +{ $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } } +{ $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ; diff --git a/extra/math/primes/primes-tests.factor b/extra/math/primes/primes-tests.factor new file mode 100644 index 0000000000..b1bcf79a49 --- /dev/null +++ b/extra/math/primes/primes-tests.factor @@ -0,0 +1,10 @@ +USING: arrays math.primes tools.test lazy-lists ; + +{ 1237 } [ 1234 next-prime ] unit-test +{ f t } [ 1234 prime? 1237 prime? ] unit-test +{ { 2 3 5 7 11 13 17 19 23 29 } } [ 10 lprimes ltake list>array ] unit-test +{ { 101 103 107 109 113 } } [ 5 100 lprimes-from ltake list>array ] unit-test +{ { 1000117 1000121 } } [ 2 1000100 lprimes-from ltake list>array ] unit-test +{ { 999983 1000003 } } [ 2 999982 lprimes-from ltake list>array ] unit-test +{ { 2 3 5 7 } } [ 10 primes-upto >array ] unit-test +{ { 999983 1000003 } } [ 999982 1000010 primes-between >array ] unit-test diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor new file mode 100644 index 0000000000..68ab5b3221 --- /dev/null +++ b/extra/math/primes/primes.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel lazy-lists math math.functions math.miller-rabin + math.primes.list math.ranges sequences sorting ; +IN: math.primes + + + +: next-prime ( n -- p ) + dup 999983 < [ + primes-under-million [ [ <=> ] binsearch 1+ ] keep nth + ] [ + next-odd find-prime-miller-rabin + ] if ; foldable + +: prime? ( n -- ? ) + dup 1000000 < [ + dup primes-under-million [ <=> ] binsearch* = + ] [ + miller-rabin + ] if ; foldable + +: lprimes ( -- list ) + 0 primes-under-million seq>list + 1000003 [ 2 + find-prime-miller-rabin ] lfrom-by + lappend ; + +: lprimes-from ( n -- list ) + dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ; + +: primes-upto ( n -- seq ) + { + { [ dup 2 < ] [ drop { } ] } + { [ dup 1000003 < ] + [ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep ] } + { [ t ] + [ primes-under-million 1000003 lprimes-from + rot [ <= ] curry lwhile list>array append ] } + } cond ; foldable + +: primes-between ( low high -- seq ) + primes-upto + >r 1- next-prime r> + [ [ <=> ] binsearch ] keep [ length ] keep ; foldable diff --git a/extra/math/primes/summary.txt b/extra/math/primes/summary.txt new file mode 100644 index 0000000000..41b4197178 --- /dev/null +++ b/extra/math/primes/summary.txt @@ -0,0 +1,2 @@ +Prime numbers test and generation + From e17a77f5cd751f34bde969d7ddab58f09a85849a Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 27 Dec 2007 15:03:22 +0100 Subject: [PATCH 40/67] New module math.primes.factors --- extra/math/primes/factors/authors.txt | 1 + extra/math/primes/factors/factors-docs.factor | 20 +++++++++ .../math/primes/factors/factors-tests.factor | 6 +++ extra/math/primes/factors/factors.factor | 41 +++++++++++++++++++ extra/math/primes/factors/summary.txt | 1 + 5 files changed, 69 insertions(+) create mode 100644 extra/math/primes/factors/authors.txt create mode 100644 extra/math/primes/factors/factors-docs.factor create mode 100644 extra/math/primes/factors/factors-tests.factor create mode 100644 extra/math/primes/factors/factors.factor create mode 100644 extra/math/primes/factors/summary.txt diff --git a/extra/math/primes/factors/authors.txt b/extra/math/primes/factors/authors.txt new file mode 100644 index 0000000000..f3b0233f74 --- /dev/null +++ b/extra/math/primes/factors/authors.txt @@ -0,0 +1 @@ +Samuel Tardieu diff --git a/extra/math/primes/factors/factors-docs.factor b/extra/math/primes/factors/factors-docs.factor new file mode 100644 index 0000000000..2238420d32 --- /dev/null +++ b/extra/math/primes/factors/factors-docs.factor @@ -0,0 +1,20 @@ +USING: help.markup help.syntax ; +IN: math.primes.factors + +{ factors count-factors unique-factors } related-words + +HELP: factors +{ $values { "n" "a positive integer" } { "seq" "a sequence" } } +{ $description { "Factorize an integer and return an ordered list of factors, possibly repeated." } } ; + +HELP: count-factors +{ $values { "n" "a positive integer" } { "seq" "a sequence" } } +{ $description { "Return a sequence of pairs representing each factor in the number and its corresponding power." } } ; + +HELP: unique-factors +{ $values { "n" "a positive integer" } { "seq" "a sequence" } } +{ $description { "Return an ordered list of unique prime factors." } } ; + +HELP: totient +{ $values { "n" "a positive integer" } { "t" "an integer" } } +{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " relatively prime to " { $snippet "n" } "." } } ; diff --git a/extra/math/primes/factors/factors-tests.factor b/extra/math/primes/factors/factors-tests.factor new file mode 100644 index 0000000000..71bdd56a81 --- /dev/null +++ b/extra/math/primes/factors/factors-tests.factor @@ -0,0 +1,6 @@ +USING: math.primes.factors tools.test ; + +{ { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test +{ { { 999983 2 } { 1000003 1 } } } [ 999969000187000867 count-factors ] unit-test +{ { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test +{ 999967000236000612 } [ 999969000187000867 totient ] unit-test diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor new file mode 100644 index 0000000000..b841d49f7d --- /dev/null +++ b/extra/math/primes/factors/factors.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel lazy-lists math math.primes namespaces sequences ; +IN: math.primes.factors + + [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ; + +: (decompose) ( n quot -- seq ) + [ lprimes rot (factors) ] { } make ; + +PRIVATE> + +: factors ( n -- seq ) + [ (factor) ] (decompose) ; foldable + +: count-factors ( n -- seq ) + [ (count) ] (decompose) ; foldable + +: unique-factors ( n -- seq ) + [ (unique) ] (decompose) ; foldable + +: totient ( n -- t ) + dup 2 < [ + drop 0 + ] [ + [ unique-factors dup 1 [ 1- * ] reduce swap product / ] keep * + ] if ; foldable diff --git a/extra/math/primes/factors/summary.txt b/extra/math/primes/factors/summary.txt new file mode 100644 index 0000000000..1440dddc7f --- /dev/null +++ b/extra/math/primes/factors/summary.txt @@ -0,0 +1 @@ +Prime factors decomposition From caa2a606c26350e64c46d94b5e0d819e54caa87e Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 27 Dec 2007 04:04:39 +0100 Subject: [PATCH 41/67] Use math.primes in project Euler problems --- extra/project-euler/003/003.factor | 10 +++++----- extra/project-euler/007/007.factor | 8 ++++---- extra/project-euler/010/010.factor | 11 +++++------ extra/project-euler/134/134.factor | 8 ++++---- 4 files changed, 18 insertions(+), 19 deletions(-) diff --git a/extra/project-euler/003/003.factor b/extra/project-euler/003/003.factor index 87db922e5f..2b229aa11b 100644 --- a/extra/project-euler/003/003.factor +++ b/extra/project-euler/003/003.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math project-euler.common sequences ; +USING: math.primes.factors sequences ; IN: project-euler.003 ! http://projecteuler.net/index.php?section=problems&id=3 @@ -17,12 +17,12 @@ IN: project-euler.003 ! -------- : largest-prime-factor ( n -- factor ) - prime-factors supremum ; + factors supremum ; : euler003 ( -- answer ) - 317584931803 largest-prime-factor ; + 317584931803 largest-prime-factor ; -! [ euler003 ] 100 ave-time -! 404 ms run / 9 ms GC ave time - 100 trials +! [ euler003 ] time +! 2 ms run / 0 ms GC time MAIN: euler003 diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index 0a9cd98865..12f06972a9 100644 --- a/extra/project-euler/007/007.factor +++ b/extra/project-euler/007/007.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.miller-rabin ; +USING: lazy-lists math math.primes ; IN: project-euler.007 ! http://projecteuler.net/index.php?section=problems&id=7 @@ -18,12 +18,12 @@ IN: project-euler.007 ! -------- : nth-prime ( n -- n ) - 2 swap 1- [ next-prime ] times ; + 1 - lprimes lnth ; : euler007 ( -- answer ) - 10001 nth-prime ; + 10001 nth-prime ; ! [ euler007 ] time -! 19230 ms run / 487 ms GC time +! 22 ms run / 0 ms GC time MAIN: euler007 diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor index 055e902776..e22d3bc39c 100644 --- a/extra/project-euler/010/010.factor +++ b/extra/project-euler/010/010.factor @@ -1,7 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel lazy-lists math math.erato math.functions math.ranges - namespaces sequences ; +USING: math.primes sequences ; IN: project-euler.010 ! http://projecteuler.net/index.php?section=problems&id=10 @@ -17,12 +16,12 @@ IN: project-euler.010 ! SOLUTION ! -------- -! Sieve of Eratosthenes and lazy summing +! Summing of prime numbers : euler010 ( -- answer ) - 0 1000000 lerato [ + ] leach ; + 1000000 primes-upto sum ; -! [ euler010 ] time -! 765 ms run / 7 ms GC time +! [ euler010 ] 100 ave-time +! 14 ms run / 0 ms GC ave time - 100 trials MAIN: euler010 diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index b30b0073d2..90d8404760 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math.algebra math math.functions math.primes.list +USING: arrays kernel lazy-lists math.algebra math math.functions math.primes math.ranges sequences ; IN: project-euler.134 @@ -23,9 +23,9 @@ IN: project-euler.134 ! SOLUTION ! -------- -! Compute the smallest power of 10 greater than m +! Compute the smallest power of 10 greater than m or equal to it : next-power-of-10 ( m -- n ) - 10 swap log 10 log / >integer [ 10 * ] times ; foldable + 10 swap log 10 log / ceiling >integer ^ ; foldable ! Compute S for a given pair (p1, p2) -- that is the smallest positive ! number such that X = p1 [npt] and X = 0 [p2] (npt being the smallest @@ -34,7 +34,7 @@ IN: project-euler.134 over 0 2array rot next-power-of-10 rot 2array chinese-remainder ; : euler134 ( -- answer ) - primes-under-million 2 tail dup 1 tail 1000003 add [ s ] 2map sum ; + 5 lprimes-from [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time ! 6743 ms run / 79 ms GC ave time - 10 trials From 05b76f181f6671eaec45d146a5ba372a6b6cf16d Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Dec 2007 13:56:03 -0500 Subject: [PATCH 42/67] Extra/trees changes --- extra/trees/avl/avl-tests.factor | 130 ++++++++++++++----------------- extra/trees/avl/avl.factor | 113 +++++++++++---------------- extra/trees/trees.factor | 13 +++- 3 files changed, 116 insertions(+), 140 deletions(-) diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index aba97ad043..5cea2c1c35 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -1,10 +1,34 @@ -USING: kernel tools.test trees trees.avl math random sequences ; +USING: kernel tools.test trees trees.avl math random sequences assocs ; IN: temporary -[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ single-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ select-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } [ single-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } [ select-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test +[ "key1" 0 "key2" 0 ] [ + T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } + [ single-rotate ] go-left + [ node-left dup node-key swap avl-node-balance ] keep + dup node-key swap avl-node-balance +] unit-test + +[ "key1" 0 "key2" 0 ] [ + T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } + [ select-rotate ] go-left + [ node-left dup node-key swap avl-node-balance ] keep + dup node-key swap avl-node-balance +] unit-test + +[ "key1" 0 "key2" 0 ] [ + T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } + [ single-rotate ] go-right + [ node-right dup node-key swap avl-node-balance ] keep + dup node-key swap avl-node-balance +] unit-test + +[ "key1" 0 "key2" 0 ] [ + T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } + [ select-rotate ] go-right + [ node-right dup node-key swap avl-node-balance ] keep + dup node-key swap avl-node-balance +] unit-test + [ "key1" -1 "key2" 0 "key3" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" f @@ -61,77 +85,37 @@ IN: temporary [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test -! random testing uncovered this little bugger -[ t t ] [ f "d" T{ avl-node - T{ node f "e" f - T{ avl-node - T{ node f "b" f - T{ avl-node T{ node f "a" } 0 } - T{ avl-node T{ node f "c" f } 0 } - 0 } - 0 } - T{ avl-node T{ node f "f" } 0 } } - -1 } node-set dup valid-avl-node? nip swap valid-node? ] unit-test +[ "eight" ] [ + "seven" 7 pick set-at + "eight" 8 pick set-at "nine" 9 pick set-at + tree-root node-value +] unit-test -[ "eight" ] [ "seven" 7 pick tree-insert "eight" 8 pick tree-insert "nine" 9 pick tree-insert tree-root node-value ] unit-test -[ "another eight" ] [ "seven" 7 pick tree-set "eight" 8 pick tree-set "another eight" 8 pick tree-set 8 swap tree-get ] unit-test -! [ "seven" 7 pick tree-insert -[ t t ] [ 3 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 9 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test ! fails when tree growth isn't terminated after a rebalance -[ t t ] [ 10 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test - -[ t t ] [ 3 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 4 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 5 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 10 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test - -[ t t ] [ 5 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 19 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 30 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 82 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test -[ t t ] [ 100 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test +[ "another eight" ] [ + "seven" 7 pick set-at + "another eight" 8 pick set-at 8 swap at +] unit-test ! borrowed from tests/bst.factor : test-tree ( -- tree ) - - "seven" 7 pick tree-insert - "nine" 9 pick tree-insert - "four" 4 pick tree-insert - "another four" 4 pick tree-insert - "replaced seven" 7 pick tree-set ; + + "seven" 7 pick set-at + "nine" 9 pick set-at + "four" 4 pick set-at + "replaced four" 4 pick set-at + "replaced seven" 7 pick set-at ; -! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all -[ "seven" ] [ "seven" 7 pick tree-insert 7 swap tree-get ] unit-test -[ "seven" t ] [ "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test -[ f f ] [ "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test -[ "seven" ] [ "seven" 7 pick tree-set 7 swap tree-get ] unit-test -[ "replacement" ] [ "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test -[ "nine" ] [ test-tree 9 swap tree-get ] unit-test -[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test -[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test -[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test - -! test tree-delete -[ f ] [ test-tree 9 over tree-delete 9 swap tree-get ] unit-test -[ "replaced seven" ] [ test-tree 9 over tree-delete 7 swap tree-get ] unit-test -[ f ] [ test-tree 4 over tree-delete-all 4 swap tree-get ] unit-test -[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete 9 swap tree-get ] unit-test -[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete-all 9 swap tree-get ] unit-test - -: test-random-deletions ( tree -- ? ) - #! deletes one node at random from the tree, checking avl and tree - #! properties after each deletion, until the tree is empty - dup stump? [ - drop t - ] [ - dup tree-keys random over tree-delete dup valid-avl-tree? over valid-tree? and [ - test-random-deletions - ] [ - dup print-tree - ] if - ] if ; - -[ t ] [ 5 random-tree test-random-deletions ] unit-test -[ t ] [ 30 random-tree test-random-deletions ] unit-test -[ t ] [ 100 random-tree test-random-deletions ] unit-test +! test set-at, at, at* +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test +[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test +[ "nine" ] [ test-tree 9 swap at ] unit-test +[ "replaced four" ] [ test-tree 4 swap at ] unit-test +[ "replaced seven" ] [ test-tree 7 swap at ] unit-test +! test delete-at +[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test +[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test +[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 654a078a23..03741b5ecd 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -1,35 +1,20 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel generic math math.functions math.parser namespaces io -sequences trees ; +USING: combinators kernel generic math math.functions math.parser +namespaces io prettyprint.backend sequences trees assocs parser ; IN: trees.avl -TUPLE: avl-tree ; +TUPLE: avl ; -: ( -- tree ) - avl-tree construct-empty over set-delegate ; +INSTANCE: avl assoc + +: ( -- tree ) + avl construct-empty over set-delegate ; TUPLE: avl-node balance ; -: ( value key -- node ) - 0 avl-node construct-boa tuck set-delegate ; - -M: avl-tree create-node ( value key tree -- node ) drop ; - -GENERIC: valid-avl-node? ( obj -- height valid? ) - -M: f valid-avl-node? ( f -- height valid? ) drop 0 t ; - -: check-balance ( node left-height right-height -- node height valid? ) - 2dup max 1+ >r swap - over avl-node-balance = r> swap ; - -M: avl-node valid-avl-node? ( node -- height valid? ) - #! check that this avl node has the right balance marked, and that it isn't unbalanced. - dup node-left valid-avl-node? >r over node-right valid-avl-node? >r - check-balance r> r> and and - rot avl-node-balance abs 2 < and ; - -: valid-avl-tree? ( tree -- valid? ) tree-root valid-avl-node? nip ; +: ( key value -- node ) + swap 0 avl-node construct-boa tuck set-delegate ; : change-balance ( node amount -- ) over avl-node-balance + swap set-avl-node-balance ; @@ -65,30 +50,25 @@ M: avl-node valid-avl-node? ( node -- height valid? ) { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller } cond ; -DEFER: avl-insert +DEFER: avl-set + +: (avl-insert) ( value key node -- node taller? ) + [ avl-set ] [ t ] if* ; + +: avl-insert ( value key node -- node taller? ) + 2dup node-key key< left right ? [ + [ node-link (avl-insert) ] keep swap + >r tuck set-node-link r> + [ dup current-side get change-balance balance-insert ] [ f ] if + ] with-side ; : avl-set ( value key node -- node taller? ) 2dup node-key key= [ -rot pick set-node-key over set-node-value f ] [ avl-insert ] if ; -: avl-insert-or-set ( value key node -- node taller? ) - "setting" get [ avl-set ] [ avl-insert ] if ; - -: (avl-insert) ( value key node -- node taller? ) - [ avl-insert-or-set ] [ t ] if* ; - -: avl-insert ( value key node -- node taller? ) - 2dup node-key key< left right ? [ - [ node-link (avl-insert) ] keep swap - >r tuck set-node-link r> [ dup current-side get change-balance balance-insert ] [ f ] if - ] with-side ; - -M: avl-node node-insert ( value key node -- node ) - [ f "setting" set avl-insert-or-set ] with-scope drop ; - -M: avl-node node-set ( value key node -- node ) - [ t "setting" set avl-insert-or-set ] with-scope drop ; +M: avl-node set-at ( value key node -- node ) + [ avl-set drop ] change-root ; : delete-select-rotate ( node -- node shorter? ) dup node+link avl-node-balance zero? [ @@ -114,7 +94,8 @@ M: avl-node node-set ( value key node -- node ) : avl-replace-with-extremity ( to-replace node -- node shorter? ) dup node-link [ - swapd avl-replace-with-extremity >r over set-node-link r> [ balance-delete ] [ f ] if + swapd avl-replace-with-extremity >r over set-node-link r> + [ balance-delete ] [ f ] if ] [ tuck copy-node-contents node+link t ] if* ; @@ -122,11 +103,8 @@ M: avl-node node-set ( value key node -- node ) : replace-with-a-child ( node -- node shorter? ) #! assumes that node is not a leaf, otherwise will recurse forever dup node-link [ - dupd [ avl-replace-with-extremity ] with-other-side >r over set-node-link r> [ - balance-delete - ] [ - f - ] if + dupd [ avl-replace-with-extremity ] with-other-side + >r over set-node-link r> [ balance-delete ] [ f ] if ] [ [ replace-with-a-child ] with-other-side ] if* ; @@ -137,7 +115,7 @@ M: avl-node node-set ( value key node -- node ) dup leaf? [ drop f t ] [ - random-side [ replace-with-a-child ] with-side ! random not necessary, just for fun + left [ replace-with-a-child ] with-side ] if ; GENERIC: avl-delete ( key node -- node shorter? deleted? ) @@ -145,30 +123,33 @@ GENERIC: avl-delete ( key node -- node shorter? deleted? ) M: f avl-delete ( key f -- f f f ) nip f f ; : (avl-delete) ( key node -- node shorter? deleted? ) - tuck node-link avl-delete >r >r over set-node-link r> [ balance-delete r> ] [ f r> ] if ; + tuck node-link avl-delete >r >r over set-node-link r> + [ balance-delete r> ] [ f r> ] if ; M: avl-node avl-delete ( key node -- node shorter? deleted? ) 2dup node-key key-side dup zero? [ drop nip avl-delete-node t ] [ - [ - (avl-delete) - ] with-side + [ (avl-delete) ] with-side ] if ; -M: avl-node node-delete ( key node -- node ) avl-delete 2drop ; +M: avl delete-at ( key node -- ) + [ avl-delete 2drop ] change-root ; -M: avl-node node-delete-all ( key node -- node ) - #! deletes until there are no more. not optimal. - dupd [ avl-delete nip ] with-scope [ - node-delete-all - ] [ - nip - ] if ; +M: avl new-assoc + 2drop ; -M: avl-node print-node ( depth node -- ) - over 1+ over node-right print-node - over [ drop " " write ] each - dup avl-node-balance number>string write " " write dup node-key number>string print - >r 1+ r> node-left print-node ; +: >avl ( assoc -- avl ) + T{ avl T{ tree f f 0 } } assoc-clone-like ; +: AVL{ + \ } [ >avl ] parse-literal ; parsing + +M: avl pprint-delims drop \ AVL{ \ } ; +M: avl >pprint-sequence >alist ; +M: avl pprint-narrow? drop t ; + +! When tuple inheritance is used, the following lines won't be necessary +M: avl assoc-size tree-count ; +M: avl clear-assoc delegate clear-assoc ; +M: avl assoc-find >r tree-root r> find-node ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 8c88e6f159..55031f77cb 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic math sequences arrays io namespaces -prettyprint.private kernel.private assocs random combinators ; +prettyprint.private kernel.private assocs random combinators +parser prettyprint.backend ; IN: trees TUPLE: tree root count ; @@ -179,3 +180,13 @@ DEFER: delete-node M: tree delete-at [ delete-bst-node ] change-root ; + +: >tree ( assoc -- bst ) + T{ tree f f 0 } assoc-clone-like ; + +: TREE{ + \ } [ >tree ] parse-literal ; parsing + +M: tree pprint-delims drop \ TREE{ \ } ; +M: tree >pprint-sequence >alist ; +M: tree pprint-narrow? drop t ; From c6ce216e0367b5bb61acca288d1651b2f8be2a11 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Dec 2007 16:38:54 -0600 Subject: [PATCH 43/67] Add ?first .. ?fourth to sequences.lib --- extra/sequences/lib/lib-tests.factor | 7 +++++++ extra/sequences/lib/lib.factor | 5 +++++ 2 files changed, 12 insertions(+) diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 72cf9ad9c4..717f463c45 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -46,3 +46,10 @@ math.functions tools.test strings ; [ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test [ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test [ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test + +[ f ] [ { } ?first ] unit-test +[ f ] [ { } ?fourth ] unit-test +[ 1 ] [ { 1 2 3 } ?first ] unit-test +[ 2 ] [ { 1 2 3 } ?second ] unit-test +[ 3 ] [ { 1 2 3 } ?third ] unit-test +[ f ] [ { 1 2 3 } ?fourth ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ea6fdd141b..442b5f317d 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -126,3 +126,8 @@ PRIVATE> : human-sort ( seq -- newseq ) [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc sort-values keys ; + +: ?first ( seq -- first/f ) 0 swap ?nth ; inline +: ?second ( seq -- second/f ) 1 swap ?nth ; inline +: ?third ( seq -- third/f ) 2 swap ?nth ; inline +: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline From 8a562bc81fe5a427c20a1ee4488256af1b24d713 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Dec 2007 20:16:55 -0500 Subject: [PATCH 44/67] Trees on the assoc protocol --- extra/trees/authors.txt | 1 + extra/trees/avl/authors.txt | 2 + extra/trees/avl/avl-docs.factor | 27 ++++++++ extra/trees/avl/avl-tests.factor | 19 +++--- extra/trees/avl/avl.factor | 23 ++++--- extra/trees/avl/summary.txt | 1 + extra/trees/binary/binary-tests.factor | 45 ------------- extra/trees/binary/binary.factor | 88 -------------------------- extra/trees/splay/authors.txt | 2 +- extra/trees/splay/splay-docs.factor | 27 ++++++++ extra/trees/splay/splay.factor | 5 +- extra/trees/summary.txt | 2 +- extra/trees/todo.txt | 2 - extra/trees/trees-docs.factor | 27 ++++++++ extra/trees/trees-tests.factor | 28 ++++++++ extra/trees/trees.factor | 18 +++++- 16 files changed, 156 insertions(+), 161 deletions(-) create mode 100644 extra/trees/avl/authors.txt create mode 100644 extra/trees/avl/avl-docs.factor create mode 100644 extra/trees/avl/summary.txt delete mode 100644 extra/trees/binary/binary-tests.factor delete mode 100644 extra/trees/binary/binary.factor create mode 100644 extra/trees/splay/splay-docs.factor delete mode 100644 extra/trees/todo.txt create mode 100644 extra/trees/trees-docs.factor create mode 100644 extra/trees/trees-tests.factor diff --git a/extra/trees/authors.txt b/extra/trees/authors.txt index e9c193bac7..39c1f37d37 100644 --- a/extra/trees/authors.txt +++ b/extra/trees/authors.txt @@ -1 +1,2 @@ Alex Chapman +Daniel Ehrenberg diff --git a/extra/trees/avl/authors.txt b/extra/trees/avl/authors.txt new file mode 100644 index 0000000000..39c1f37d37 --- /dev/null +++ b/extra/trees/avl/authors.txt @@ -0,0 +1,2 @@ +Alex Chapman +Daniel Ehrenberg diff --git a/extra/trees/avl/avl-docs.factor b/extra/trees/avl/avl-docs.factor new file mode 100644 index 0000000000..12465eec98 --- /dev/null +++ b/extra/trees/avl/avl-docs.factor @@ -0,0 +1,27 @@ +USING: help.syntax help.markup trees.avl assocs ; + +HELP: AVL{ +{ $syntax "AVL{ { key value }... }" } +{ $values { "key" "a key" } { "value" "a value" } } +{ $description "Literal syntax for an AVL tree." } ; + +HELP: +{ $values { "tree" avl } } +{ $description "Creates an empty AVL tree" } ; + +HELP: >avl +{ $values { "assoc" assoc } { "avl" avl } } +{ $description "Converts any " { $link assoc } " into an AVL tree." } ; + +HELP: avl +{ $class-description "This is the class for AVL trees. These conform to the assoc protocol and have efficient (logarithmic time) storage and retrieval operations." } ; + +ARTICLE: { "avl" "intro" } "AVL trees" +"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol." +{ $subsection avl } +{ $subsection } +{ $subsection >avl } +{ $subsection POSTPONE: AVL{ } ; + +IN: trees.avl +ABOUT: { "avl" "intro" } diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index 5cea2c1c35..0964ea7e56 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -91,21 +91,22 @@ IN: temporary tree-root node-value ] unit-test -[ "another eight" ] [ +[ "another eight" ] [ ! ERROR! "seven" 7 pick set-at "another eight" 8 pick set-at 8 swap at ] unit-test -! borrowed from tests/bst.factor : test-tree ( -- tree ) - - "seven" 7 pick set-at - "nine" 9 pick set-at - "four" 4 pick set-at - "replaced four" 4 pick set-at - "replaced seven" 7 pick set-at ; + AVL{ + { 7 "seven" } + { 9 "nine" } + { 4 "four" } + { 4 "replaced four" } + { 7 "replaced seven" } + } clone ; ! test set-at, at, at* +[ t ] [ test-tree avl? ] unit-test [ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test [ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test [ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test @@ -115,7 +116,7 @@ IN: temporary [ "replaced four" ] [ test-tree 4 swap at ] unit-test [ "replaced seven" ] [ test-tree 7 swap at ] unit-test -! test delete-at +! test delete-at--all errors! [ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test [ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test [ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 03741b5ecd..0c4bf5af28 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -52,22 +52,22 @@ TUPLE: avl-node balance ; DEFER: avl-set -: (avl-insert) ( value key node -- node taller? ) - [ avl-set ] [ t ] if* ; - : avl-insert ( value key node -- node taller? ) 2dup node-key key< left right ? [ - [ node-link (avl-insert) ] keep swap + [ node-link avl-set ] keep swap >r tuck set-node-link r> [ dup current-side get change-balance balance-insert ] [ f ] if ] with-side ; -: avl-set ( value key node -- node taller? ) +: (avl-set) ( value key node -- node taller? ) 2dup node-key key= [ -rot pick set-node-key over set-node-value f ] [ avl-insert ] if ; -M: avl-node set-at ( value key node -- node ) +: avl-set ( value key node -- node taller? ) + [ (avl-set) ] [ t ] if* ; + +M: avl set-at ( value key node -- node ) [ avl-set drop ] change-root ; : delete-select-rotate ( node -- node shorter? ) @@ -136,20 +136,23 @@ M: avl-node avl-delete ( key node -- node shorter? deleted? ) M: avl delete-at ( key node -- ) [ avl-delete 2drop ] change-root ; -M: avl new-assoc - 2drop ; +M: avl new-assoc 2drop ; : >avl ( assoc -- avl ) T{ avl T{ tree f f 0 } } assoc-clone-like ; +M: avl assoc-like + drop dup avl? [ >avl ] unless ; + : AVL{ \ } [ >avl ] parse-literal ; parsing M: avl pprint-delims drop \ AVL{ \ } ; -M: avl >pprint-sequence >alist ; -M: avl pprint-narrow? drop t ; ! When tuple inheritance is used, the following lines won't be necessary M: avl assoc-size tree-count ; M: avl clear-assoc delegate clear-assoc ; M: avl assoc-find >r tree-root r> find-node ; +M: avl clone dup assoc-clone-like ; +M: avl >pprint-sequence >alist ; +M: avl pprint-narrow? drop t ; diff --git a/extra/trees/avl/summary.txt b/extra/trees/avl/summary.txt new file mode 100644 index 0000000000..c2360c2ed3 --- /dev/null +++ b/extra/trees/avl/summary.txt @@ -0,0 +1 @@ +Balanced AVL trees diff --git a/extra/trees/binary/binary-tests.factor b/extra/trees/binary/binary-tests.factor deleted file mode 100644 index 7abf2f0da5..0000000000 --- a/extra/trees/binary/binary-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: trees trees.binary tools.test kernel sequences ; -IN: temporary - -: test-tree ( -- tree ) - - "seven" 7 pick tree-insert - "nine" 9 pick tree-insert - "four" 4 pick tree-insert - "another four" 4 pick tree-insert - "replaced seven" 7 pick tree-set ; - -! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all -[ "seven" ] [ "seven" 7 pick tree-insert 7 swap tree-get ] unit-test -[ "seven" t ] [ "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test -[ f f ] [ "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test -[ "seven" ] [ "seven" 7 pick tree-set 7 swap tree-get ] unit-test -[ "replacement" ] [ "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test -[ "four" ] [ test-tree 4 swap tree-get ] unit-test -[ "nine" ] [ test-tree 9 swap tree-get ] unit-test -[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test -[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test -[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test - -! test tree-delete -[ f ] [ test-tree 9 over tree-delete 9 swap tree-get ] unit-test -[ "replaced seven" ] [ test-tree 9 over tree-delete 7 swap tree-get ] unit-test -[ "four" ] [ test-tree 9 over tree-delete 4 swap tree-get ] unit-test -! TODO: sometimes this shows up as "another four" because of randomisation -! [ "nine" "four" ] [ test-tree 7 over tree-delete 9 over tree-get 4 rot tree-get ] unit-test -! [ "another four" ] [ test-tree 4 over tree-delete 4 swap tree-get ] unit-test -[ f ] [ test-tree 4 over tree-delete-all 4 swap tree-get ] unit-test -[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete 9 swap tree-get ] unit-test -[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete-all 9 swap tree-get ] unit-test - -! test valid-node? -[ t ] [ T{ node f 0 } valid-node? ] unit-test -[ t ] [ T{ node f 0 f T{ node f -1 } } valid-node? ] unit-test -[ t ] [ T{ node f 0 f f T{ node f 1 } } valid-node? ] unit-test -[ t ] [ T{ node f 0 f T{ node f -1 } T{ node f 1 } } valid-node? ] unit-test -[ f ] [ T{ node f 0 f T{ node f 1 } } valid-node? ] unit-test -[ f ] [ T{ node f 0 f f T{ node f -1 } } valid-node? ] unit-test - -! random testing -[ t ] [ 10 random-tree valid-tree? ] unit-test - diff --git a/extra/trees/binary/binary.factor b/extra/trees/binary/binary.factor deleted file mode 100644 index 5fc7abc636..0000000000 --- a/extra/trees/binary/binary.factor +++ /dev/null @@ -1,88 +0,0 @@ -! Copyright (C) 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel generic math trees ; -IN: trees.binary - -TUPLE: bst ; - -: ( -- tree ) bst construct-empty over set-delegate ; - -TUPLE: bst-node ; - -: ( value key -- node ) - bst-node construct-empty tuck set-delegate ; - -M: bst create-node ( value key tree -- node ) drop ; - -M: bst-node node-insert ( value key node -- node ) - 2dup node-key key-side [ - [ node-link [ node-insert ] [ ] if* ] keep tuck set-node-link - ] with-side ; - -M: bst-node node-set ( value key node -- node ) - 2dup node-key key-side dup 0 = [ - drop nip [ set-node-value ] keep - ] [ - [ [ node-link [ node-set ] [ ] if* ] keep tuck set-node-link ] with-side - ] if ; - -DEFER: delete-node - -: (prune-extremity) ( parent node -- new-extremity ) - dup node-link [ - rot drop (prune-extremity) - ] [ - tuck delete-node swap set-node-link - ] if* ; - -: prune-extremity ( node -- new-extremity ) - #! remove and return the leftmost or rightmost child of this node. - #! assumes at least one child - dup node-link (prune-extremity) ; - -: replace-with-child ( node -- node ) - dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ; - -: replace-with-extremity ( node -- node ) - dup node-link dup node+link [ - ! predecessor/successor is not the immediate child - [ prune-extremity ] with-other-side dupd copy-node-contents - ] [ - ! node-link is the predecessor/successor - drop replace-with-child - ] if ; - -: delete-node-with-two-children ( node -- node ) - #! randomised to minimise tree unbalancing - random-side [ replace-with-extremity ] with-side ; - -: delete-node ( node -- node ) - #! delete this node, returning its replacement - dup node-left [ - dup node-right [ - delete-node-with-two-children - ] [ - node-left ! left but no right - ] if - ] [ - dup node-right [ - node-right ! right but not left - ] [ - drop f ! no children - ] if - ] if ; - -M: bst-node node-delete ( key node -- node ) - 2dup node-key key-side dup zero? [ - drop nip delete-node - ] [ - [ tuck node-link node-delete over set-node-link ] with-side - ] if ; - -M: bst-node node-delete-all ( key node -- node ) - 2dup node-key key-side dup zero? [ - drop delete-node node-delete-all - ] [ - [ tuck node-link node-delete-all over set-node-link ] with-side - ] if ; - diff --git a/extra/trees/splay/authors.txt b/extra/trees/splay/authors.txt index 09839c9c91..a2c0a7cc80 100644 --- a/extra/trees/splay/authors.txt +++ b/extra/trees/splay/authors.txt @@ -1 +1 @@ -Mackenzie Straight +Mackenzie Straight, Daniel Ehrenberg diff --git a/extra/trees/splay/splay-docs.factor b/extra/trees/splay/splay-docs.factor new file mode 100644 index 0000000000..b621155e73 --- /dev/null +++ b/extra/trees/splay/splay-docs.factor @@ -0,0 +1,27 @@ +USING: help.syntax help.markup trees.splay assocs ; + +HELP: SPLAY{ +{ $syntax "SPLAY{ { key value }... }" } +{ $values { "key" "a key" } { "value" "a value" } } +{ $description "Literal syntax for an splay tree." } ; + +HELP: +{ $values { "tree" splay } } +{ $description "Creates an empty splay tree" } ; + +HELP: >splay +{ $values { "assoc" assoc } { "splay" splay } } +{ $description "Converts any " { $link assoc } " into an splay tree." } ; + +HELP: splay +{ $class-description "This is the class for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These conform to the assoc protocol." } ; + +ARTICLE: { "splay" "intro" } "Splay trees" +"This is a library for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These trees conform to the assoc protocol." +{ $subsection splay } +{ $subsection } +{ $subsection >splay } +{ $subsection POSTPONE: SPLAY{ } ; + +IN: trees.splay +ABOUT: { "splay" "intro" } diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index dd40a77501..5f7c50cfb2 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -143,10 +143,11 @@ M: splay assoc-like ] unless ; M: splay pprint-delims drop \ SPLAY{ \ } ; -M: splay >pprint-sequence >alist ; -M: splay pprint-narrow? drop t ; ! When tuple inheritance is used, the following lines won't be necessary M: splay assoc-size tree-count ; M: splay clear-assoc delegate clear-assoc ; M: splay assoc-find >r tree-root r> find-node ; +M: splay clone dup assoc-clone-like ; +M: splay >pprint-sequence >alist ; +M: splay pprint-narrow? drop t ; diff --git a/extra/trees/summary.txt b/extra/trees/summary.txt index cf7b64c8a1..18ad35db8f 100644 --- a/extra/trees/summary.txt +++ b/extra/trees/summary.txt @@ -1 +1 @@ -Binary search and avl (balanced) trees +Binary search trees diff --git a/extra/trees/todo.txt b/extra/trees/todo.txt deleted file mode 100644 index 7eb295302a..0000000000 --- a/extra/trees/todo.txt +++ /dev/null @@ -1,2 +0,0 @@ -- Make trees.splay use the same tree protocol as trees.binary and trees.avl -- Make all trees follow the assoc protocol diff --git a/extra/trees/trees-docs.factor b/extra/trees/trees-docs.factor new file mode 100644 index 0000000000..12bae4bac5 --- /dev/null +++ b/extra/trees/trees-docs.factor @@ -0,0 +1,27 @@ +USING: help.syntax help.markup trees assocs ; + +HELP: TREE{ +{ $syntax "TREE{ { key value }... }" } +{ $values { "key" "a key" } { "value" "a value" } } +{ $description "Literal syntax for an unbalanced tree." } ; + +HELP: +{ $values { "tree" tree } } +{ $description "Creates an empty unbalanced binary tree" } ; + +HELP: >tree +{ $values { "assoc" assoc } { "tree" tree } } +{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ; + +HELP: tree +{ $class-description "This is the class for unbalanced binary search trees. It is not usually intended to be used directly but rather as a basis for other trees." } ; + +ARTICLE: { "trees" "intro" } "Binary search trees" +"This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol." +{ $subsection tree } +{ $subsection } +{ $subsection >tree } +{ $subsection POSTPONE: TREE{ } ; + +IN: trees +ABOUT: { "trees" "intro" } diff --git a/extra/trees/trees-tests.factor b/extra/trees/trees-tests.factor new file mode 100644 index 0000000000..2795b0d5da --- /dev/null +++ b/extra/trees/trees-tests.factor @@ -0,0 +1,28 @@ +USING: trees assocs tools.test kernel sequences ; +IN: temporary + +: test-tree ( -- tree ) + TREE{ + { 7 "seven" } + { 9 "nine" } + { 4 "four" } + { 4 "replaced four" } + { 7 "replaced seven" } + } clone ; + +! test set-at, at, at* +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test +[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test +[ "replaced four" ] [ test-tree 4 swap at ] unit-test +[ "nine" ] [ test-tree 9 swap at ] unit-test + +! test delete-at +[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test +[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test +[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test +[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test +[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test + diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 55031f77cb..971c961cbc 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -79,13 +79,13 @@ M: tree at* ( key tree -- value ? ) drop nip [ set-node-value ] keep ] [ [ - [ node-link [ node-set ] [ ] if* ] keep + [ node-link [ node-set ] [ swap ] if* ] keep [ set-node-link ] keep ] with-side ] if ; M: tree set-at ( value key tree -- ) - [ [ node-set ] [ ] if* ] change-root ; + [ [ node-set ] [ swap ] if* ] change-root ; : valid-node? ( node -- ? ) [ @@ -181,9 +181,21 @@ DEFER: delete-node M: tree delete-at [ delete-bst-node ] change-root ; -: >tree ( assoc -- bst ) +M: tree new-assoc + 2drop ; + +M: tree clone dup assoc-clone-like ; + +: >tree ( assoc -- tree ) T{ tree f f 0 } assoc-clone-like ; +GENERIC: tree-assoc-like ( assoc -- tree ) +M: tuple tree-assoc-like ! will need changes for tuple inheritance + dup delegate dup tree? [ nip ] [ drop >tree ] if ; +M: tree tree-assoc-like ; +M: assoc tree-assoc-like >tree ; +M: tree assoc-like drop tree-assoc-like ; + : TREE{ \ } [ >tree ] parse-literal ; parsing From c9368951606704deb541c1795e63ac2c9d38f2f0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Dec 2007 21:03:12 -0500 Subject: [PATCH 45/67] sequences.deep bug fix --- extra/sequences/deep/deep.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor index 6e36878b78..c55647bbcb 100644 --- a/extra/sequences/deep/deep.factor +++ b/extra/sequences/deep/deep.factor @@ -5,11 +5,10 @@ IN: sequences.deep ! All traversal goes in postorder -GENERIC: branch? ( object -- ? ) -M: sequence branch? drop t ; -M: string branch? drop f ; -M: number branch? drop f ; -M: object branch? drop f ; +: branch? ( object -- ? ) + dup sequence? [ + dup string? swap number? or not + ] [ drop f ] if ; : deep-each ( obj quot -- ) [ call ] 2keep over branch? From 9760eb4fb197d265eb04a8c1a00432987c3153f2 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 28 Dec 2007 14:17:31 +0100 Subject: [PATCH 46/67] Update collect-benchmarks so that it does not rely onto computed stack effect --- extra/project-euler/ave-time/ave-time.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index d481b30c84..b908dbd7b0 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,23 +1,21 @@ ! Copyright (c) 2007 Aaron Schaefer ! See http://factorcode.org/license.txt for BSD license. -USING: arrays effects inference io kernel math math.functions math.parser +USING: arrays combinators io kernel math math.functions math.parser math.statistics namespaces sequences tools.time ; IN: project-euler.ave-time : collect-benchmarks ( quot n -- seq ) - [ - 1- [ [ benchmark ] keep -rot 2array , [ clean-stack ] keep ] times - ] curry { } make >r benchmark 2array r> swap add ; inline + [ + >r >r datastack r> [ benchmark 2array , ] curry tuck + [ with-datastack drop ] 2curry r> swap times call + ] { } make ; : ave-time ( quot n -- ) [ collect-benchmarks ] keep swap ave-benchmarks [ From a9903e1bdc59f2810df1e94a87faf676204e3237 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 28 Dec 2007 13:44:00 +0100 Subject: [PATCH 47/67] Remove some words in math.algebra and change implementation --- extra/math/algebra/algebra-docs.factor | 8 ------ extra/math/algebra/algebra-tests.factor | 2 -- extra/math/algebra/algebra.factor | 33 ++----------------------- 3 files changed, 2 insertions(+), 41 deletions(-) diff --git a/extra/math/algebra/algebra-docs.factor b/extra/math/algebra/algebra-docs.factor index 14fdc9a505..a623268403 100644 --- a/extra/math/algebra/algebra-docs.factor +++ b/extra/math/algebra/algebra-docs.factor @@ -1,14 +1,6 @@ USING: help.markup help.syntax ; IN: math.algebra -HELP: ext-euclidian -{ $values { "a" "a positive integer" } { "b" "a positive integer" } { "gcd" "a positive integer" } { "u" "an integer" } { "v" "an integer" } } -{ $description "Compute the greatest common divisor " { $snippet "gcd" } " of integers " { $snippet "a" } " and " { $snippet "b" } " using the extended Euclidian algorithm. In addition, this word also computes two other values " { $snippet "u" } " and " { $snippet "v" } " such that " { $snippet "a*u + b*v = gcd" } "." } ; - -HELP: ring-inverse -{ $values { "a" "a positive integer" } { "b" "a positive integer" } { "i" "a positive integer" } } -{ $description "If " { $snippet "a" } " and " { $snippet "b" } " are coprime, " { $snippet "i" } " is the smallest positive integer such as " { $snippet "a*i = 1" } " in ring " { $snippet "Z/bZ" } "." } ; - HELP: chinese-remainder { $values { "aseq" "a sequence of integers" } { "nseq" "a sequence of positive integers" } { "x" "an integer" } } { $description "If " { $snippet "nseq" } " integers are pairwise coprimes, " { $snippet "x" } " is the smallest positive integer congruent to each element in " { $snippet "aseq" } " modulo the corresponding element in " { $snippet "nseq" } "." } ; diff --git a/extra/math/algebra/algebra-tests.factor b/extra/math/algebra/algebra-tests.factor index 86b513aecd..51aa97995c 100644 --- a/extra/math/algebra/algebra-tests.factor +++ b/extra/math/algebra/algebra-tests.factor @@ -1,5 +1,3 @@ USING: math.algebra tools.test ; -{ 2 5 -2 } [ 10 24 ext-euclidian ] unit-test -{ 17 } [ 19 23 ring-inverse ] unit-test { 11 } [ { 2 3 1 } { 3 4 5 } chinese-remainder ] unit-test diff --git a/extra/math/algebra/algebra.factor b/extra/math/algebra/algebra.factor index 0dfd086e70..8bb8420d1a 100644 --- a/extra/math/algebra/algebra.factor +++ b/extra/math/algebra/algebra.factor @@ -1,37 +1,8 @@ ! Copyright (c) 2007 Samuel Tardieu ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.ranges namespaces sequences vars ; +USING: kernel math math.functions sequences ; IN: math.algebra -" and ">r", so we chose to use "s" instead. - -VARS: s-1 u-1 v-1 s u v ; - -: init ( a b -- ) - >s >s-1 0 >u 1 >u-1 1 >v 0 >v-1 ; - -: advance ( r u v -- ) - v> >v-1 >v u> >u-1 >u s> >s-1 >s ; inline - -: step ( -- ) - s-1> s> 2dup /mod drop [ * - ] keep u-1> over u> * - v-1> rot v> * - - advance ; - -PRIVATE> - -! Extended Euclidian: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm -: ext-euclidian ( a b -- gcd u v ) - [ init [ s> 0 > ] [ step ] [ ] while s-1> u-1> v-1> ] with-scope ; foldable - -! Inverse a in ring Z/bZ -: ring-inverse ( a b -- i ) - [ ext-euclidian drop nip ] keep rem ; foldable - -! Chinese remainder: http://en.wikipedia.org/wiki/Chinese_remainder_theorem : chinese-remainder ( aseq nseq -- x ) dup product - [ [ over / [ ext-euclidian ] keep * 2nip * ] curry 2map sum ] keep rem ; - foldable + [ [ over / [ swap gcd drop ] keep * * ] curry 2map sum ] keep rem ; foldable From a680c3abc5e4ebc55fa3bc5727a767687670004b Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 28 Dec 2007 14:18:15 +0100 Subject: [PATCH 48/67] Fix bug in project Euler 134 and update timings wrt math.algebra code changes --- extra/project-euler/134/134.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index 90d8404760..55f8a8dab8 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -34,9 +34,9 @@ IN: project-euler.134 over 0 2array rot next-power-of-10 rot 2array chinese-remainder ; : euler134 ( -- answer ) - 5 lprimes-from [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; + 0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time -! 6743 ms run / 79 ms GC ave time - 10 trials +! 3797 ms run / 30 ms GC ave time - 10 trials MAIN: euler134 From 483028cc518581dca0a236b1accea700957519a2 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 28 Dec 2007 14:52:11 +0100 Subject: [PATCH 49/67] Update problems list and simplify code --- extra/project-euler/project-euler.factor | 25 +++++++++++------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index c35101785a..601acb70b5 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,11 +1,14 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files kernel math.parser namespaces sequences strings - vocabs vocabs.loader system project-euler.ave-time +USING: definitions io io.files kernel math.parser sequences strings + vocabs vocabs.loader project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 - project-euler.013 project-euler.014 project-euler.015 project-euler.016 ; + project-euler.013 project-euler.014 project-euler.015 project-euler.016 + project-euler.017 project-euler.018 project-euler.019 + project-euler.067 + project-euler.134 ; IN: project-euler number ; : number>euler ( n -- str ) - number>string string>digits 3 0 pad-left [ number>string ] map concat ; + number>string 3 CHAR: 0 pad-left ; -: solution-path ( n -- str ) - number>euler dup [ - "project-euler" vocab-root ?resource-path % - os "windows" = [ - "\\project-euler\\" % % "\\" % % ".factor" % - ] [ - "/project-euler/" % % "/" % % ".factor" % - ] if - ] "" make ; +: solution-path ( n -- str/f ) + number>euler "project-euler." swap append vocab where + dup [ first ?resource-path ] when ; PRIVATE> : problem-solved? ( n -- ? ) - solution-path exists? ; + solution-path ; : run-project-euler ( -- ) problem-prompt dup problem-solved? [ From 4a28fe910d225143e6ad456a39612b2146067eba Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 29 Dec 2007 01:33:21 -0500 Subject: [PATCH 50/67] XML prettyprinter --- extra/html/elements/elements.factor | 4 +- extra/html/html.factor | 6 +- extra/xml/test/templating.factor | 2 +- extra/xml/test/test.factor | 6 +- extra/xml/writer/writer.factor | 99 ++++++++++++++++++++++++----- 5 files changed, 94 insertions(+), 23 deletions(-) diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 0b70f5aa5c..d737c113a8 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel namespaces prettyprint quotations -sequences strings words ; +sequences strings words xml.writer ; IN: html.elements @@ -123,7 +123,7 @@ SYMBOL: html " " write-html write-html "='" write-html - write + escape-quoted-string write "'" write-html ; : define-attribute-word ( name -- ) diff --git a/extra/html/html.factor b/extra/html/html.factor index 9e98831482..6def0089c9 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -142,7 +142,7 @@ M: html-block-stream stream-close ( quot style stream -- ) table-style " border-collapse: collapse;" append =style ; : do-escaping ( string style -- string ) - html swap at [ chars>entities ] unless ; + html swap at [ escape-string ] unless ; PRIVATE> @@ -151,13 +151,13 @@ M: html-stream stream-write1 ( char stream -- ) >r 1string r> stream-write ; M: html-stream stream-write ( str stream -- ) - >r chars>entities r> delegate stream-write ; + >r escape-string r> delegate stream-write ; M: html-stream make-span-stream ( style stream -- stream' ) html-span-stream ; M: html-stream stream-format ( str style stream -- ) - >r html over at [ >r chars>entities r> ] unless r> + >r html over at [ >r escape-string r> ] unless r> format-html-span ; M: html-stream make-block-stream ( style stream -- stream' ) diff --git a/extra/xml/test/templating.factor b/extra/xml/test/templating.factor index ca2d973510..0ee4ae51b0 100644 --- a/extra/xml/test/templating.factor +++ b/extra/xml/test/templating.factor @@ -40,4 +40,4 @@ M: object (r-ref) drop ; sample-doc string>xml dup template xml>string ] with-scope ; -[ "foo
blah

" ] [ test-refs ] unit-test +[ "\nfoo

" ] [ test-refs ] unit-test diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index 8c4757517d..80a508787e 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -26,7 +26,7 @@ SYMBOL: xml-file ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test [ "that" ] [ xml-file get "this" swap at ] unit-test -[ "" ] +[ "\n" ] [ "" string>xml xml>string ] unit-test [ "abcd" ] [ "

abcd
" string>xml @@ -44,5 +44,7 @@ SYMBOL: xml-file at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test -[ "bar baz" ] +[ "\nbar baz" ] [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test +[ "\n\n bar\n" ] +[ " bar " string>xml pprint-xml>string ] unit-test diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index b0b707fd42..7bd1cc3046 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -4,18 +4,60 @@ USING: hashtables kernel math namespaces sequences strings io io.streams.string xml.data assocs ; IN: xml.writer -: write-entities +SYMBOL: xml-pprint? +SYMBOL: sensitive-tags +SYMBOL: indentation +SYMBOL: indenter +" " indenter set-global + +: sensitive? ( tag -- ? ) + sensitive-tags get swap [ names-match? ] curry contains? ; + +: ?indent ( -- ) + xml-pprint? get [ + nl indentation get indenter get [ write ] each + ] when ; + +: indent ( -- ) + xml-pprint? get [ 1 indentation +@ ] when ; + +: unindent ( -- ) + xml-pprint? get [ -1 indentation +@ ] when ; + +: trim-whitespace ( string -- no-whitespace ) + [ [ blank? not ] find drop 0 or ] keep + [ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep + subseq ; + +: ?filter-children ( children -- no-whitespace ) + xml-pprint? get [ + [ dup string? [ trim-whitespace ] when ] map + [ dup empty? swap string? and not ] subset + ] when ; + +: entities-out H{ { CHAR: < "<" } { CHAR: > ">" } { CHAR: & "&" } + } ; + +: quoted-entities-out + H{ + { CHAR: & "&" } { CHAR: ' "'" } { CHAR: " """ } } ; -: chars>entities ( str -- str ) +: escape-string-by ( str table -- escaped ) #! Convert <, >, &, ' and " to HTML entities. - [ [ dup write-entities at [ % ] [ , ] ?if ] each ] "" make ; + [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ; + +: escape-string ( str -- newstr ) + entities-out escape-string-by ; + +: escape-quoted-string ( str -- newstr ) + quoted-entities-out escape-string-by ; : print-name ( name -- ) dup name-space f like @@ -27,27 +69,35 @@ IN: xml.writer " " write swap print-name "=\"" write - chars>entities write + escape-quoted-string write "\"" write ] assoc-each ; GENERIC: write-item ( object -- ) M: string write-item - chars>entities write ; + escape-string write ; + +: write-tag ( tag -- ) + CHAR: < write1 + dup print-name tag-attrs print-attrs ; M: contained-tag write-item - CHAR: < write1 - dup print-name tag-attrs print-attrs - "/>" write ; + write-tag "/>" write ; + +: write-children ( tag -- ) + indent tag-children ?filter-children + [ ?indent write-item ] each unindent ; + +: write-end-tag ( tag -- ) + ?indent " write1 ; M: open-tag write-item - CHAR: < write1 - dup print-name - dup tag-attrs print-attrs - CHAR: > write1 - dup tag-children [ write-item ] each - " write1 ; + xml-pprint? [ [ + over sensitive? not and xml-pprint? set + dup write-tag CHAR: > write1 + dup write-children write-end-tag + ] keep ] change ; M: comment write-item "" write ; @@ -62,7 +112,7 @@ M: instruction write-item "" write ; + "\"?>\n" write ; : write-chunk ( seq -- ) [ write-item ] each ; @@ -79,3 +129,22 @@ M: instruction write-item : xml>string ( xml -- string ) [ write-xml ] string-out ; +: with-xml-pprint ( sensitive-tags quot -- ) + [ + swap [ assure-name ] map sensitive-tags set + 0 indentation set + xml-pprint? on + call + ] with-scope ; inline + +: pprint-xml-but ( xml sensitive-tags -- ) + [ print-xml ] with-xml-pprint ; + +: pprint-xml ( xml -- ) + f pprint-xml-but ; + +: pprint-xml>string-but ( xml sensitive-tags -- string ) + [ xml>string ] with-xml-pprint ; + +: pprint-xml>string ( xml -- string ) + f pprint-xml>string-but ; From 8eff6af3229f69a958118d5f7f4acf1ea7b77d63 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 29 Dec 2007 14:09:50 -0500 Subject: [PATCH 51/67] Fix edge-case and perfect square errors with sum-proper-divisors --- extra/project-euler/021/021.factor | 12 ++---------- extra/project-euler/common/common.factor | 12 ++++++++++++ 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor index cc0ba5b88d..c3859665e7 100644 --- a/extra/project-euler/021/021.factor +++ b/extra/project-euler/021/021.factor @@ -25,17 +25,9 @@ IN: project-euler.021 ! SOLUTION ! -------- -fixnum 2 swap [a,b] [ - [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each drop - ] { } make sum 1+ ; - -PRIVATE> - : amicable? ( n -- ? ) - dup d { [ 2dup = not ] [ 2dup d = ] } && 2nip ; + dup sum-proper-divisors + { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } && 2nip ; : euler021 ( -- answer ) 10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ; diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 0a31df82b7..4c7987371d 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -62,6 +62,18 @@ PRIVATE> : prime-factors ( n -- seq ) prime-factorization prune >array ; +: (sum-divisors) ( n -- sum ) + dup sqrt >fixnum [1,b] [ + [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each + dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if + ] { } make sum ; + +: sum-divisors ( n -- sum ) + dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ; + +: sum-proper-divisors ( n -- sum ) + dup sum-divisors swap - ; + ! The divisor function, counts the number of divisors : tau ( n -- n ) prime-factorization* flip second 1 [ 1+ * ] reduce ; From fe2ef1e41839c1711993b6552a1b1a9dfec93eb1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 30 Dec 2007 04:21:03 -0500 Subject: [PATCH 52/67] Shufflers tests fix --- extra/shufflers/shufflers-tests.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/shufflers/shufflers-tests.factor b/extra/shufflers/shufflers-tests.factor index d59e18d0dc..5bcdab8068 100644 --- a/extra/shufflers/shufflers-tests.factor +++ b/extra/shufflers/shufflers-tests.factor @@ -1,7 +1,5 @@ USING: shufflers tools.test ; -[ { 1 1 0 0 1 0 } ] [ BIN: 010011 2 6 translate ] unit-test - SHUFFLE: abcd 4 [ ] [ 1 2 3 4 abcd- ] unit-test [ 1 2 1 2 ] [ 1 2 3 abc-abab ] unit-test From bea0eb759abed06a08a5906e933b5c1faed563a2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 30 Dec 2007 04:24:05 -0500 Subject: [PATCH 53/67] XML docs update --- extra/xml/xml-docs.factor | 89 ++++++++++++++++++++++++++------------- 1 file changed, 60 insertions(+), 29 deletions(-) diff --git a/extra/xml/xml-docs.factor b/extra/xml/xml-docs.factor index e1c4d035fd..785538332a 100644 --- a/extra/xml/xml-docs.factor +++ b/extra/xml/xml-docs.factor @@ -7,14 +7,29 @@ strings sequences io ; HELP: string>xml { $values { "string" "a string" } { "xml" "an xml document" } } { $description "converts a string into an " { $link xml } - " datatype for further processing" } -{ $see-also xml>string xml-reprint } ; + " datatype for further processing" } ; + +HELP: read-xml +{ $values { "stream" "a stream that supports readln" } + { "xml" "an XML document" } } +{ $description "exausts the given stream, reading an XML document from it" } ; + +HELP: file>xml +{ $values { "filename" "a string representing a filename" } + { "xml" "an XML document" } } +{ $description "opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree" } ; + +{ string>xml read-xml file>xml } related-words HELP: xml>string { $values { "xml" "an xml document" } { "string" "a string" } } { $description "converts an xml document (" { $link xml } ") into a string" } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } -{ $see-also string>xml xml-reprint write-xml } ; +{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; + +HELP: pprint-xml>string +{ $values { "xml" "an xml document" } { "string" "a string" } } +{ $description "converts an xml document (" { $link xml } ") into a string in a prettyprinted form." } +{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; HELP: xml-parse-error { $class-description "the exception class that all parsing errors in XML documents are in." } ; @@ -22,20 +37,34 @@ HELP: xml-parse-error HELP: xml-reprint { $values { "string" "a string of XML" } } { $description "parses XML and prints it out again, for testing purposes" } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } -{ $see-also write-xml xml>string string>xml } ; +{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; HELP: write-xml { $values { "xml" "an XML document" } } { $description "prints the contents of an XML document (" { $link xml } ") to stdio" } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } -{ $see-also xml>string xml-reprint read-xml } ; +{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; -HELP: read-xml -{ $values { "stream" "a stream that supports readln" } - { "xml" "an XML document" } } -{ $description "exausts the given stream, reading an XML document from it" } -{ $see-also write-xml string>xml } ; +HELP: print-xml +{ $values { "xml" "an XML document" } } +{ $description "prints the contents of an XML document (" { $link xml } ") to stdio, followed by a newline" } +{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; + +HELP: pprint-xml +{ $values { "xml" "an XML document" } } +{ $description "prints the contents of an XML document (" { $link xml } ") to stdio in a prettyprinted form." } +{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; + +HELP: pprint-xml-but +{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } } +{ $description "Prettyprints an XML document, leaving the whitespace of the tags with names in sensitive-tags intact." } +{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; + +HELP: pprint-xml>string-but +{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } { "string" string } } +{ $description "Prettyprints an XML document, returning the result as a string and leaving the whitespace of the tags with names in sensitive-tags intact." } +{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; + +{ xml>string print-xml write-xml pprint-xml xml-reprint pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words HELP: PROCESS: { $syntax "PROCESS: word" } @@ -318,26 +347,27 @@ HELP: with-html-entities { $description "calls the given quotation using HTML entity values" } { $see-also html-entities with-entities } ; -HELP: file>xml -{ $values { "filename" "a string representing a filename" } - { "xml" "an XML document" } } -{ $description "opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree" } -{ $see-also string>xml read-xml } ; - -ARTICLE: { "xml" "basic" } "Basic words for XML processing" - "These are the most basic words needed for processing an XML document" - $nl - "Parsing XML:" +ARTICLE: { "xml" "reading" } "Reading XML" + "The following words are used to read something into an XML document" { $subsection string>xml } { $subsection read-xml } { $subsection xml-chunk } - { $subsection file>xml } - "Printing XML" - { $subsection xml>string } - { $subsection write-xml } + { $subsection file>xml } ; + +ARTICLE: { "xml" "writing" } "Writing XML" + "These words are used in implementing prettyprint" { $subsection write-item } { $subsection write-chunk } - "Other" + "These words are used to print XML normally" + { $subsection xml>string } + { $subsection write-xml } + { $subsection print-xml } + "These words are used to prettyprint XML" + { $subsection pprint-xml>string } + { $subsection pprint-xml>string-but } + { $subsection pprint-xml } + { $subsection pprint-xml-but } + "This word reads and writes XML" { $subsection xml-reprint } ; ARTICLE: { "xml" "classes" } "XML data classes" @@ -433,7 +463,8 @@ ARTICLE: { "xml" "intro" } "XML" "The XML module attempts to implement the XML 1.1 standard, converting strings of text into XML and vice versa. It currently is a work in progress." $nl "The XML module was implemented by Daniel Ehrenberg, with contributions from the Factor community" - { $subsection { "xml" "basic" } } + { $subsection { "xml" "reading" } } + { $subsection { "xml" "writing" } } { $subsection { "xml" "classes" } } { $subsection { "xml" "construct" } } { $subsection { "xml" "utils" } } From dc18466c271b62394208fe2b619e323f4f87060c Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sun, 30 Dec 2007 13:08:31 +0100 Subject: [PATCH 54/67] Project Euler solutions are not always numbers --- extra/project-euler/project-euler.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 601acb70b5..4cd4a3826e 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: definitions io io.files kernel math.parser sequences strings +USING: definitions io io.files kernel math math.parser sequences strings vocabs vocabs.loader project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 @@ -32,7 +32,7 @@ PRIVATE> : run-project-euler ( -- ) problem-prompt dup problem-solved? [ dup number>euler "project-euler." swap append run - "Answer: " swap number>string append print + "Answer: " swap dup number? [ number>string ] when append print "Source: " swap solution-path append print ] [ drop "That problem has not been solved yet..." print From 392da8029fa067444406d98ae61a30655c7ccb53 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 29 Dec 2007 01:18:00 +0100 Subject: [PATCH 55/67] Factor solution to project Euler problem 175 --- extra/project-euler/175/175.factor | 54 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 3 +- 2 files changed, 56 insertions(+), 1 deletion(-) create mode 100644 extra/project-euler/175/175.factor diff --git a/extra/project-euler/175/175.factor b/extra/project-euler/175/175.factor new file mode 100644 index 0000000000..db1760c017 --- /dev/null +++ b/extra/project-euler/175/175.factor @@ -0,0 +1,54 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel math math.parser math.ranges sequences vectors ; +IN: project-euler.175 + +! http://projecteuler.net/index.php?section=problems&id=175 + +! DESCRIPTION +! ----------- + +! Define f(0)=1 and f(n) to be the number of ways to write n as a sum of +! powers of 2 where no power occurs more than twice. + +! For example, f(10)=5 since there are five different ways to express +! 10: 10 = 8+2 = 8+1+1 = 4+4+2 = 4+2+2+1+1 = 4+4+1+1 + +! It can be shown that for every fraction p/q (p0, q0) there exists at +! least one integer n such that f(n)/f(n-1)=p/q. + +! For instance, the smallest n for which f(n)/f(n-1)=13/17 is 241. The +! binary expansion of 241 is 11110001. Reading this binary number from +! the most significant bit to the least significant bit there are 4 +! one's, 3 zeroes and 1 one. We shall call the string 4,3,1 the +! Shortened Binary Expansion of 241. + +! Find the Shortened Binary Expansion of the smallest n for which +! f(n)/f(n-1)=123456789/987654321. + +! Give your answer as comma separated integers, without any whitespaces. + +! SOLUTION +! -------- + +: add-bits ( vec n b -- ) + over zero? [ + 3drop + ] [ + pick length 1 bitand = [ over pop + ] when swap push + ] if ; + +: compute ( vec ratio -- ) + { + { [ dup integer? ] [ 1- 0 add-bits ] } + { [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] } + { [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] } + } cond ; + +: euler175 ( -- result ) + V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ; + +! [ euler175 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler175 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 4cd4a3826e..9b5c41feed 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -8,7 +8,8 @@ USING: definitions io io.files kernel math math.parser sequences strings project-euler.013 project-euler.014 project-euler.015 project-euler.016 project-euler.017 project-euler.018 project-euler.019 project-euler.067 - project-euler.134 ; + project-euler.134 + project-euler.175 ; IN: project-euler Date: Sun, 30 Dec 2007 13:30:26 +0100 Subject: [PATCH 56/67] Factor solution to project Euler problem 169 --- extra/project-euler/169/169.factor | 41 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 1 + 2 files changed, 42 insertions(+) create mode 100644 extra/project-euler/169/169.factor diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor new file mode 100644 index 0000000000..959715e4f9 --- /dev/null +++ b/extra/project-euler/169/169.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +IN: project-euler.169 +USING: combinators kernel math math.functions memoize ; + +! http://projecteuler.net/index.php?section=problems&id=169 + +! DESCRIPTION +! ----------- + +! Define f(0)=1 and f(n) to be the number of different ways n can be +! expressed as a sum of integer powers of 2 using each power no more +! than twice. + +! For example, f(10)=5 since there are five different ways to express 10: + +! 1 + 1 + 8 +! 1 + 1 + 4 + 4 +! 1 + 1 + 2 + 2 + 4 +! 2 + 4 + 4 +! 2 + 8 + +! What is f(1025)? + +! SOLUTION +! -------- + +MEMO: fn ( n -- x ) + { + { [ dup 2 < ] [ drop 1 ] } + { [ dup odd? ] [ 2/ fn ] } + { [ t ] [ 2/ [ fn ] keep 1- fn + ] } + } cond ; + +: euler169 ( -- result ) + 10 25 ^ fn ; + +! [ euler169 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler169 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 9b5c41feed..f256f03138 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -9,6 +9,7 @@ USING: definitions io io.files kernel math math.parser sequences strings project-euler.017 project-euler.018 project-euler.019 project-euler.067 project-euler.134 + project-euler.169 project-euler.175 ; IN: project-euler From b55f6d91145ba8bbc8d2573abe5cb3b3d3203ba0 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Mon, 31 Dec 2007 00:24:24 +0100 Subject: [PATCH 57/67] Use constant stack effect to prevent compilation errors --- extra/project-euler/011/011.factor | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/extra/project-euler/011/011.factor b/extra/project-euler/011/011.factor index 9739ee971c..7520fb9182 100644 --- a/extra/project-euler/011/011.factor +++ b/extra/project-euler/011/011.factor @@ -72,13 +72,13 @@ IN: project-euler.011 : pad-front ( matrix -- matrix ) [ - length [ 0 ] each - ] keep [ append ] map ; + length [ 0 ] map + ] keep [ append ] 2map ; : pad-back ( matrix -- matrix ) [ - length [ 0 ] each - ] keep [ append ] map ; + length [ 0 ] map + ] keep [ append ] 2map ; : diagonal/ ( -- matrix ) horizontal reverse pad-front pad-back flip ; @@ -98,9 +98,6 @@ PRIVATE> [ call 4 max-product , ] each ] { } make supremum ; -! TODO: solution works but doesn't completely compile due to the creation of -! the diagonal matrices, there must be a cleaner way to generate those - ! [ euler011 ] 100 ave-time ! 4 ms run / 0 ms GC ave time - 100 trials From 724eff0089c3f47ce1d819b37df10a15a7e462da Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Mon, 31 Dec 2007 00:28:11 +0100 Subject: [PATCH 58/67] Use group to do the grouping to be closer to the original problem --- extra/project-euler/011/011.factor | 44 +++++++++++++++--------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/extra/project-euler/011/011.factor b/extra/project-euler/011/011.factor index 7520fb9182..322c361ee0 100644 --- a/extra/project-euler/011/011.factor +++ b/extra/project-euler/011/011.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces project-euler.common sequences ; +USING: kernel namespaces project-euler.common sequences splitting ; IN: project-euler.011 ! http://projecteuler.net/index.php?section=problems&id=11 @@ -45,27 +45,27 @@ IN: project-euler.011 : horizontal ( -- matrix ) { - { 08 02 22 97 38 15 00 40 00 75 04 05 07 78 52 12 50 77 91 08 } - { 49 49 99 40 17 81 18 57 60 87 17 40 98 43 69 48 04 56 62 00 } - { 81 49 31 73 55 79 14 29 93 71 40 67 53 88 30 03 49 13 36 65 } - { 52 70 95 23 04 60 11 42 69 24 68 56 01 32 56 71 37 02 36 91 } - { 22 31 16 71 51 67 63 89 41 92 36 54 22 40 40 28 66 33 13 80 } - { 24 47 32 60 99 03 45 02 44 75 33 53 78 36 84 20 35 17 12 50 } - { 32 98 81 28 64 23 67 10 26 38 40 67 59 54 70 66 18 38 64 70 } - { 67 26 20 68 02 62 12 20 95 63 94 39 63 08 40 91 66 49 94 21 } - { 24 55 58 05 66 73 99 26 97 17 78 78 96 83 14 88 34 89 63 72 } - { 21 36 23 09 75 00 76 44 20 45 35 14 00 61 33 97 34 31 33 95 } - { 78 17 53 28 22 75 31 67 15 94 03 80 04 62 16 14 09 53 56 92 } - { 16 39 05 42 96 35 31 47 55 58 88 24 00 17 54 24 36 29 85 57 } - { 86 56 00 48 35 71 89 07 05 44 44 37 44 60 21 58 51 54 17 58 } - { 19 80 81 68 05 94 47 69 28 73 92 13 86 52 17 77 04 89 55 40 } - { 04 52 08 83 97 35 99 16 07 97 57 32 16 26 26 79 33 27 98 66 } - { 88 36 68 87 57 62 20 72 03 46 33 67 46 55 12 32 63 93 53 69 } - { 04 42 16 73 38 25 39 11 24 94 72 18 08 46 29 32 40 62 76 36 } - { 20 69 36 41 72 30 23 88 34 62 99 69 82 67 59 85 74 04 36 16 } - { 20 73 35 29 78 31 90 01 74 31 49 71 48 86 81 16 23 57 05 54 } - { 01 70 54 71 83 51 54 69 16 92 33 48 61 43 52 01 89 19 67 48 } - } ; + 08 02 22 97 38 15 00 40 00 75 04 05 07 78 52 12 50 77 91 08 + 49 49 99 40 17 81 18 57 60 87 17 40 98 43 69 48 04 56 62 00 + 81 49 31 73 55 79 14 29 93 71 40 67 53 88 30 03 49 13 36 65 + 52 70 95 23 04 60 11 42 69 24 68 56 01 32 56 71 37 02 36 91 + 22 31 16 71 51 67 63 89 41 92 36 54 22 40 40 28 66 33 13 80 + 24 47 32 60 99 03 45 02 44 75 33 53 78 36 84 20 35 17 12 50 + 32 98 81 28 64 23 67 10 26 38 40 67 59 54 70 66 18 38 64 70 + 67 26 20 68 02 62 12 20 95 63 94 39 63 08 40 91 66 49 94 21 + 24 55 58 05 66 73 99 26 97 17 78 78 96 83 14 88 34 89 63 72 + 21 36 23 09 75 00 76 44 20 45 35 14 00 61 33 97 34 31 33 95 + 78 17 53 28 22 75 31 67 15 94 03 80 04 62 16 14 09 53 56 92 + 16 39 05 42 96 35 31 47 55 58 88 24 00 17 54 24 36 29 85 57 + 86 56 00 48 35 71 89 07 05 44 44 37 44 60 21 58 51 54 17 58 + 19 80 81 68 05 94 47 69 28 73 92 13 86 52 17 77 04 89 55 40 + 04 52 08 83 97 35 99 16 07 97 57 32 16 26 26 79 33 27 98 66 + 88 36 68 87 57 62 20 72 03 46 33 67 46 55 12 32 63 93 53 69 + 04 42 16 73 38 25 39 11 24 94 72 18 08 46 29 32 40 62 76 36 + 20 69 36 41 72 30 23 88 34 62 99 69 82 67 59 85 74 04 36 16 + 20 73 35 29 78 31 90 01 74 31 49 71 48 86 81 16 23 57 05 54 + 01 70 54 71 83 51 54 69 16 92 33 48 61 43 52 01 89 19 67 48 + } 20 group ; : vertical ( -- matrix ) horizontal flip ; From cf19d8a37cef0c510381c066b376315bd96e2611 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Mon, 31 Dec 2007 02:59:53 +0100 Subject: [PATCH 59/67] Factor solution to project Euler problem 173 --- extra/project-euler/173/173.factor | 34 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 2 +- 2 files changed, 35 insertions(+), 1 deletion(-) create mode 100644 extra/project-euler/173/173.factor diff --git a/extra/project-euler/173/173.factor b/extra/project-euler/173/173.factor new file mode 100644 index 0000000000..4eef3ec3e2 --- /dev/null +++ b/extra/project-euler/173/173.factor @@ -0,0 +1,34 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.ranges sequences ; +IN: project-euler.173 + +! http://projecteuler.net/index.php?section=problems&id=173 + +! DESCRIPTION +! ----------- + +! We shall define a square lamina to be a square outline with a square +! "hole" so that the shape possesses vertical and horizontal +! symmetry. For example, using exactly thirty-two square tiles we can +! form two different square laminae: [see URL for figure] + +! With one-hundred tiles, and not necessarily using all of the tiles at +! one time, it is possible to form forty-one different square laminae. + +! Using up to one million tiles how many different square laminae can be +! formed? + +! SOLUTION +! -------- + +: laminaes ( upper -- n ) + 4 / dup sqrt [1,b] 0 rot [ over /mod drop - - ] curry reduce ; + +: euler173 ( -- answer ) + 1000000 laminaes ; + +! [ euler173 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler173 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index f256f03138..68c71da049 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -10,7 +10,7 @@ USING: definitions io io.files kernel math math.parser sequences strings project-euler.067 project-euler.134 project-euler.169 - project-euler.175 ; + project-euler.173 project-euler.175 ; IN: project-euler Date: Sun, 30 Dec 2007 21:29:27 -0500 Subject: [PATCH 60/67] Move file-contents word to core/io/io.factor --- core/io/io.factor | 7 +++++-- extra/mad/api/api.factor | 34 +++++++++++++++------------------- 2 files changed, 20 insertions(+), 21 deletions(-) diff --git a/core/io/io.factor b/core/io/io.factor index 50393f96bb..9c5cf782e7 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: hashtables generic kernel math namespaces sequences strings + continuations assocs io.files io.styles sbufs ; IN: io -USING: hashtables generic kernel math namespaces -sequences strings continuations assocs io.styles sbufs ; GENERIC: stream-close ( stream -- ) GENERIC: set-timeout ( n stream -- ) @@ -90,3 +90,6 @@ SYMBOL: stdio : contents ( stream -- str ) 2048 [ stream-copy ] keep >string ; + +: file-contents ( path -- str ) + dup swap file-length [ stream-copy ] keep >string ; diff --git a/extra/mad/api/api.factor b/extra/mad/api/api.factor index e3178b95f9..d803fa64e0 100644 --- a/extra/mad/api/api.factor +++ b/extra/mad/api/api.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Adam Wendt. ! See http://factorcode.org/license.txt for BSD license. -! -USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad namespaces prettyprint sbufs sequences tools.interpreter vars ; +USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad + namespaces prettyprint sbufs sequences tools.interpreter vars ; IN: mad.api VARS: buffer-start buffer-length output-callback-var ; @@ -16,27 +16,27 @@ VARS: buffer-start buffer-length output-callback-var ; { "void*" "mad_header*" } create-mad-callback-generic ; inline : create-filter-callback ( sequence -- alien ) - { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline + { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline : create-output-callback ( sequence -- alien ) - { "void*" "mad_header*" "mad_pcm*" } create-mad-callback-generic ; inline + { "void*" "mad_header*" "mad_pcm*" } create-mad-callback-generic ; inline : create-error-callback ( sequence -- alien ) - { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline + { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline : create-message-callback ( sequence -- alien ) - { "void*" "void*" "uint*" } create-mad-callback-generic ; inline + { "void*" "void*" "uint*" } create-mad-callback-generic ; inline : input ( buffer mad_stream -- mad_flow ) "input" print flush - nip ! mad_stream + nip ! mad_stream buffer-start get ! mad_stream start buffer-length get ! mad_stream start length dup 0 = ! mad-stream start length bool [ 3drop MAD_FLOW_STOP ] ! mad_flow - [ mad_stream_buffer ! - 0 buffer-length set ! - MAD_FLOW_CONTINUE ] if ; ! mad_flow + [ mad_stream_buffer ! + 0 buffer-length set ! + MAD_FLOW_CONTINUE ] if ; ! mad_flow : input-callback ( -- callback ) [ input ] create-input-callback ; @@ -46,11 +46,11 @@ VARS: buffer-start buffer-length output-callback-var ; : filter-callback ( -- callback ) [ "filter" print flush 3drop MAD_FLOW_CONTINUE ] create-filter-callback ; - -: write-sample ( sample -- ) - 4 >le write ; -: output ( data header pcm -- mad_flow ) +: write-sample ( sample -- ) + 4 >le write ; + +: output ( data header pcm -- mad_flow ) "output" . flush -rot 2drop output-callback-var> call [ MAD_FLOW_CONTINUE ] [ MAD_FLOW_STOP ] if ; @@ -80,11 +80,8 @@ VARS: buffer-start buffer-length output-callback-var ; : make-decoder ( -- decoder ) "mad_decoder" malloc-object ; -: file-contents ( path -- string ) - dup swap file-length [ stream-copy ] keep >byte-array ; - : malloc-file-contents ( path -- alien ) - file-contents malloc-byte-array ; + file-contents >byte-array malloc-byte-array ; : mad-run ( -- int ) make-decoder [ mad-init ] keep MAD_DECODER_MODE_SYNC mad_decoder_run ; @@ -98,4 +95,3 @@ VARS: buffer-start buffer-length output-callback-var ; : mad-test ( -- results ) [ output-stdout ] >output-callback-var "/home/adam/download/mp3/Misc/wutbf.mp3" decode-mp3 ; - From df5fa5f23909146ec9ddb15327158f248971b45a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 30 Dec 2007 23:59:56 -0500 Subject: [PATCH 61/67] combinators.lib:construct-slots --- extra/combinators/lib/lib.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index e4d66d4725..a24e7bd791 100644 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -161,3 +161,8 @@ MACRO: map-call-with2 ( quots -- ) r> length [ narray ] curry append ; MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ; + +MACRO: construct-slots ( assoc tuple-class -- tuple ) + [ construct-empty ] curry swap [ + [ dip ] curry swap 1quotation [ keep ] curry compose + ] { } assoc>map concat compose ; From 5a347d513c59099732be41acf681d3d1e31e3898 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 31 Dec 2007 00:44:40 -0500 Subject: [PATCH 62/67] Macros now memoize when not used as compiler transform --- extra/macros/macros.factor | 12 ++++++------ extra/memoize/memoize.factor | 6 +++++- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index 1c23a1c85e..9c1cb6210b 100755 --- a/extra/macros/macros.factor +++ b/extra/macros/macros.factor @@ -2,18 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel sequences words effects inference.transforms - combinators assocs definitions quotations namespaces ; +combinators assocs definitions quotations namespaces memoize ; IN: macros -: (:) +: (:) ( -- word definition effect-in ) CREATE dup reset-generic parse-definition over "declared-effect" word-prop effect-in length ; -: (MACRO:) - >r - 2dup "macro" set-word-prop - 2dup [ call ] append define-compound +: (MACRO:) ( word definition effect-in -- ) + >r 2dup "macro" set-word-prop + 2dup over "declared-effect" word-prop memoize-quot + [ call ] append define-compound r> define-transform ; : MACRO: diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 75f8ae5ea0..97da6f0a33 100644 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel hashtables sequences arrays words namespaces -parser math assocs effects definitions ; +parser math assocs effects definitions quotations ; IN: memoize : packer ( n -- quot ) @@ -46,3 +46,7 @@ PREDICATE: compound memoized "memoize" word-prop ; M: memoized definer drop \ MEMO: \ ; ; M: memoized definition "memo-quot" word-prop ; + +: memoize-quot ( quot effect -- memo-quot ) + gensym swap dupd "declared-effect" set-word-prop + dup rot define-memoized 1quotation ; From 897a8ed8aabd15ba2fe411bb6f523ad74dcdefb4 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 31 Dec 2007 14:47:24 -0500 Subject: [PATCH 63/67] Replace ' contents' with 'file-contents' in all vocabs --- core/io/crc32/crc32.factor | 2 +- core/io/files/files-tests.factor | 4 +- core/source-files/source-files.factor | 2 +- extra/cryptlib/cryptlib-tests.factor | 60 +++++++++---------- extra/html/parser/analyzer/analyzer.factor | 6 +- .../server/templating/templating-tests.factor | 10 +--- .../http/server/templating/templating.factor | 2 +- extra/icfp/2006/2006.factor | 14 ++--- extra/io/mmap/mmap-tests.factor | 6 +- extra/project-euler/022/022.factor | 2 +- extra/project-euler/067/067.factor | 6 +- extra/project-euler/common/common.factor | 9 +++ extra/xmode/code2html/code2html.factor | 7 +-- 13 files changed, 65 insertions(+), 65 deletions(-) diff --git a/core/io/crc32/crc32.factor b/core/io/crc32/crc32.factor index 2b101945e7..1c0c2e9f5c 100644 --- a/core/io/crc32/crc32.factor +++ b/core/io/crc32/crc32.factor @@ -27,4 +27,4 @@ DEFER: crc32-table inline : crc32 ( seq -- n ) >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ; -: file-crc32 ( path -- n ) contents crc32 ; +: file-crc32 ( path -- n ) file-contents crc32 ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 4f071e03b7..3559a3487b 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -23,11 +23,11 @@ USING: tools.test io.files io threads kernel ; ] unit-test [ "Hello world.\nHello appender.\n" ] [ - "test-foo.txt" resource-path contents + "test-foo.txt" resource-path file-contents ] unit-test [ "Hello appender.\n" ] [ - "test-bar.txt" resource-path contents + "test-bar.txt" resource-path file-contents ] unit-test [ ] [ "test-foo.txt" resource-path delete-file ] unit-test diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 57ae7d7a53..4df59e5dd9 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -63,7 +63,7 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ swap ?resource-path dup exists? - [ contents record-checksum ] [ 2drop ] if + [ file-contents record-checksum ] [ 2drop ] if ] assoc-each ; M: pathname where pathname-string 1 2array ; diff --git a/extra/cryptlib/cryptlib-tests.factor b/extra/cryptlib/cryptlib-tests.factor index 8cce40778e..c404114716 100644 --- a/extra/cryptlib/cryptlib-tests.factor +++ b/extra/cryptlib/cryptlib-tests.factor @@ -1,4 +1,4 @@ -USING: cryptlib.libcl cryptlib prettyprint kernel alien sequences libc math +USING: cryptlib.libcl cryptlib prettyprint kernel alien sequences libc math tools.test io io.files continuations alien.c-types splitting generic.math ; "=========================================================" print @@ -53,12 +53,12 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; ! de-envelope CRYPT_FORMAT_AUTO [ [ envelope-handle get-pop-buffer get-bytes-copied push-data ] [ - dup CRYPT_ENVELOPE_RESOURCE = [ + dup CRYPT_ENVELOPE_RESOURCE = [ envelope-handle CRYPT_ENVINFO_PASSWORD - "password" set-attribute-string - ] [ + "password" set-attribute-string + ] [ rethrow - ] if + ] if ] recover drop get-bytes-copied . envelope-handle flush-data @@ -124,17 +124,17 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; ! de-envelope CRYPT_FORMAT_AUTO [ [ envelope-handle get-pop-buffer get-bytes-copied push-data ] [ - dup CRYPT_ENVELOPE_RESOURCE = [ + dup CRYPT_ENVELOPE_RESOURCE = [ CRYPT_ALGO_IDEA create-context context-handle CRYPT_CTXINFO_KEY "0123456789ABCDEF" set-attribute-string - envelope-handle CRYPT_ENVINFO_SESSIONKEY context-handle *int + envelope-handle CRYPT_ENVINFO_SESSIONKEY context-handle *int set-attribute - ] [ - rethrow - ] if + ] [ + rethrow + ] if ] recover drop - + get-bytes-copied . destroy-context envelope-handle flush-data @@ -151,8 +151,8 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; [ ! envelope CRYPT_FORMAT_CRYPTLIB [ - "extra/cryptlib/test/large_data.txt" resource-path - contents set-pop-buffer + "extra/cryptlib/test/large_data.txt" resource-path + file-contents set-pop-buffer envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE get-pop-buffer alien>char-string length 10000 + set-attribute envelope-handle CRYPT_ENVINFO_DATASIZE @@ -175,9 +175,9 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; envelope-handle get-bytes-copied pop-data get-bytes-copied . ! pop-buffer-string . - [ "/opt/local/lib/libcl.dylib(dylib1.o):" ] + [ "/opt/local/lib/libcl.dylib(dylib1.o):" ] [ pop-buffer-string "\n" split first ] unit-test - [ "00000000 t __mh_dylib_header" ] + [ "00000000 t __mh_dylib_header" ] [ pop-buffer-string "\n" split last/first first ] unit-test ] with-envelope ] with-cryptlib @@ -192,7 +192,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; CRYPT_FORMAT_CRYPTLIB [ envelope-handle CRYPT_ENVINFO_PASSWORD "password" set-attribute-string "extra/cryptlib/test/large_data.txt" resource-path - contents set-pop-buffer + file-contents set-pop-buffer envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE get-pop-buffer alien>char-string length 10000 + set-attribute envelope-handle CRYPT_ENVINFO_DATASIZE @@ -204,17 +204,17 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; get-bytes-copied . pop-buffer-string . ] with-envelope - + ! de-envelope CRYPT_FORMAT_AUTO [ envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE 130000 set-attribute [ envelope-handle get-pop-buffer get-bytes-copied push-data ] [ - dup CRYPT_ENVELOPE_RESOURCE = [ + dup CRYPT_ENVELOPE_RESOURCE = [ envelope-handle CRYPT_ENVINFO_PASSWORD "password" set-attribute-string - ] [ - rethrow - ] if + ] [ + rethrow + ] if ] recover drop get-bytes-copied . @@ -226,7 +226,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; [ "/opt/local/lib/libcl.dylib(dylib1.o):" ] [ pop-buffer-string "\n" split first ] unit-test - [ "00000000 t __mh_dylib_header" ] + [ "00000000 t __mh_dylib_header" ] [ pop-buffer-string "\n" split last/first first ] unit-test ] with-envelope ] with-cryptlib @@ -274,7 +274,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; check-certificate add-public-key f 0 CRYPT_CERTFORMAT_TEXT_CERTIFICATE export-certificate - get-cert-length *int dup malloc swap + get-cert-length *int dup malloc swap CRYPT_CERTFORMAT_TEXT_CERTIFICATE export-certificate get-cert-buffer alien>char-string print ] with-certificate @@ -295,15 +295,15 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; ! ... ! localhost's password: (any password will be accepted) - ! If you want to run the test again you should clean the [localhost]:3000 - ! ssh-rsa entry in the known_hosts file, in your home directory under the .ssh + ! If you want to run the test again you should clean the [localhost]:3000 + ! ssh-rsa entry in the known_hosts file, in your home directory under the .ssh ! folder, since the test generates a new RSA certificate on every run. [ CRYPT_KEYSET_FILE "extra/cryptlib/test/keys.p15" resource-path CRYPT_KEYOPT_READONLY [ CRYPT_KEYID_NAME "private key" "password" get-private-key - + CRYPT_SESSION_SSH_SERVER [ session-handle CRYPT_SESSINFO_SERVER_NAME "localhost" @@ -312,7 +312,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; session-handle CRYPT_SESSINFO_SERVER_PORT 3000 set-attribute session-handle CRYPT_SESSINFO_PRIVATEKEY - + context-handle *int set-attribute [ session-handle CRYPT_SESSINFO_ACTIVE 1 set-attribute ] [ @@ -328,9 +328,9 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; length push-data session-handle flush-data - ] [ - rethrow - ] if + ] [ + rethrow + ] if ] recover drop ] with-session ] with-keyset diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 9303b81055..168c2002a8 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -81,11 +81,11 @@ IN: html.parser.analyzer ! ] if ; -! clear "/Users/erg/web/fark.html" contents parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map +! clear "/Users/erg/web/fark.html" file-contents parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map -! clear "/Users/erg/web/hostels.html" contents parse-html "Currency" "name" pick find-first-attribute-key-value +! clear "/Users/erg/web/hostels.html" file-contents parse-html "Currency" "name" pick find-first-attribute-key-value -! clear "/Users/erg/web/hostels.html" contents parse-html +! clear "/Users/erg/web/hostels.html" file-contents parse-html ! "Currency" "name" pick find-first-attribute-key-value ! pick find-between remove-blank-text diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/templating-tests.factor index 6ccf3ed154..d979a071f2 100644 --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/templating-tests.factor @@ -1,18 +1,14 @@ -USING: io io.files io.streams.string http.server.templating -kernel tools.test sequences ; +USING: io io.files io.streams.string http.server.templating kernel tools.test + sequences ; IN: temporary : test-template ( path -- ? ) "extra/http/server/templating/test/" swap append - [ ".fhtml" append resource-path [ run-template-file ] string-out ] keep - - ".html" append resource-path - contents - = ; + ".html" append resource-path file-contents = ; [ t ] [ "example" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index cd587799c2..680f7b73d5 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -82,7 +82,7 @@ DEFER: <% delimiter templating-vocab use+ dup source-file file set ! so that reload works properly [ - ?resource-path contents + ?resource-path file-contents [ eval-template ] [ html-error. drop ] recover ] keep ] with-scope diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index 90ac9dc03e..53c7fd5a9b 100644 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -1,9 +1,7 @@ ! Copyright (C) 2007 Gavin Harrison ! See http://factorcode.org/license.txt for BSD license. - -USING: kernel math sequences kernel.private namespaces arrays -io io.files splitting io.binary math.functions vectors -quotations combinators.private ; +USING: kernel math sequences kernel.private namespaces arrays io io.files + splitting io.binary math.functions vectors quotations combinators.private ; IN: icfp.2006 SYMBOL: regs @@ -58,7 +56,7 @@ SYMBOL: open-arrays >r get-cba r> swap >r >r [ reg-val ] 2apply swap r> call r> set-reg f ; inline - + : op1 ( opcode -- ? ) [ swap arr-val ] binary-op ; @@ -89,7 +87,7 @@ SYMBOL: open-arrays : op8 ( opcode -- ? ) ?grow-storage - get-cb >r reg-val open-arrays get pop [ new-array ] keep r> + get-cb >r reg-val open-arrays get pop [ new-array ] keep r> set-reg f ; : op9 ( opcode -- ? ) @@ -111,7 +109,7 @@ SYMBOL: open-arrays : op13 ( opcode -- ? ) [ get-value ] keep get-special set-reg f ; - + : advance ( -- val opcode ) finger get arrays get first nth finger inc dup get-op ; @@ -129,7 +127,7 @@ SYMBOL: open-arrays [ run-op exec-loop ] unless ; : load-platters ( path -- ) - contents 4 group [ be> ] map + file-contents 4 group [ be> ] map 0 arrays get set-nth ; : init ( path -- ) diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index 729882deeb..a01481ecdc 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,11 +1,9 @@ -USING: io io.mmap io.files kernel tools.test continuations -sequences ; +USING: io io.mmap io.files kernel tools.test continuations sequences ; IN: temporary [ "mmap-test-file.txt" resource-path delete-file ] catch drop [ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-stream ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test -[ "22345" ] [ "mmap-test-file.txt" resource-path contents ] unit-test +[ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test [ "mmap-test-file.txt" resource-path delete-file ] catch drop - diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 1c8c8743f9..f523f586c5 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -38,7 +38,7 @@ IN: project-euler.022 ] "" make ; : source-022 ( -- seq ) - (source-022) contents [ quotable? ] subset "," split ; + (source-022) file-contents [ quotable? ] subset "," split ; : alpha-value ( str -- n ) string>digits [ 9 - ] sigma ; diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index c97ad90128..a675a5635e 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -38,12 +38,12 @@ IN: project-euler.067 - lines [ " " split [ string>number ] map ] map ; + "resource:extra/project-euler/067/triangle.txt" ?resource-path + lines [ " " split [ string>number ] map ] map ; PRIVATE> -: euler067 ( -- best ) +: euler067 ( -- answer ) pyramid propagate-all first first ; ! [ euler067 ] 100 ave-time diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 4c7987371d..2e18d744fc 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -74,6 +74,15 @@ PRIVATE> : sum-proper-divisors ( n -- sum ) dup sum-divisors swap - ; +: abundant? ( n -- ? ) + dup sum-proper-divisors < ; + +: deficient? ( n -- ? ) + dup sum-proper-divisors > ; + +: perfect? ( n -- ? ) + dup sum-proper-divisors = ; + ! The divisor function, counts the number of divisors : tau ( n -- n ) prime-factorization* flip second 1 [ 1+ * ] reduce ; diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index dfc50988a3..3db70cf2e9 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -1,6 +1,5 @@ -USING: xmode.tokens xmode.marker -xmode.catalog kernel html html.elements io io.files -sequences words ; +USING: xmode.tokens xmode.marker xmode.catalog kernel html html.elements io + io.files sequences words ; IN: xmode.code2html : htmlize-tokens ( tokens -- ) @@ -21,7 +20,7 @@ IN: xmode.code2html : default-stylesheet ( -- ) ; : htmlize-stream ( path stream -- ) From 81026a92bf77deff0d49cf11df59953df410dd35 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 1 Jan 2008 22:30:22 -0500 Subject: [PATCH 64/67] Reverting RSS changes; fixing unit tests --- extra/rss/rss-tests.factor | 4 ++-- extra/rss/rss.factor | 30 +++++++++++++++++------------- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 18aa8440b9..68a40704b3 100644 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -10,7 +10,7 @@ USING: rss io kernel io.files tools.test ; f "Meerkat" "http://meerkat.oreillynet.com" - V{ + { T{ entry f @@ -26,7 +26,7 @@ USING: rss io kernel io.files tools.test ; f "dive into mark" "http://example.org/" - V{ + { T{ entry f diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 233dfcb221..39018a9912 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -85,22 +85,26 @@ C: entry ] if ; ! Atom generation +: simple-tag, ( content name -- ) + [ , ] tag, ; + +: simple-tag*, ( content name attrs -- ) + [ , ] tag*, ; + : entry, ( entry -- ) - << entry >> [ - << title >> [ dup entry-title , ] - << link [ dup entry-link ] == href // >> - << published >> [ dup entry-pub-date , ] - << content >> [ entry-description , ] - ] ; + "entry" [ + dup entry-title "title" { { "type" "html" } } simple-tag*, + "link" over entry-link "href" associate contained*, + dup entry-pub-date "published" simple-tag, + entry-description [ "content" { { "type" "html" } } simple-tag*, ] when* + ] tag, ; : feed>xml ( feed -- xml ) - > [ - << title >> [ dup feed-title , ] - << link [ dup feed-link ] == href // >> - feed-entries [ entry, ] each - ] - XML> ; + "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ + dup feed-title "title" simple-tag, + "link" over feed-link "href" associate contained*, + feed-entries [ entry, ] each + ] make-xml* ; : write-feed ( feed -- ) feed>xml write-xml ; From 598c53d6eb8f3fca8cb8901d6e8b63912c517cd6 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 3 Jan 2008 11:52:46 +0100 Subject: [PATCH 65/67] Use cut-slice instead of cut in a loop --- extra/project-euler/018/018.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index bc3bf56c86..b43ff5234f 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -68,7 +68,7 @@ IN: project-euler.018 63 66 04 68 89 53 67 30 73 16 69 87 40 31 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 } - 15 [ 1+ cut swap ] map nip ; + 15 [ 1+ cut-slice swap ] map nip ; PRIVATE> From 1de0f57e2bbef78b821c70b51a9a62f48fb2028d Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 4 Jan 2008 18:40:16 -0600 Subject: [PATCH 66/67] trees.splay authors.txt typo fix --- extra/trees/splay/authors.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/trees/splay/authors.txt b/extra/trees/splay/authors.txt index a2c0a7cc80..06a7cfb215 100644 --- a/extra/trees/splay/authors.txt +++ b/extra/trees/splay/authors.txt @@ -1 +1,2 @@ -Mackenzie Straight, Daniel Ehrenberg +Mackenzie Straight +Daniel Ehrenberg From ace3419a8a60db5be97a5973813d586ee6740aaa Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 4 Jan 2008 18:56:04 -0600 Subject: [PATCH 67/67] Remove circular dependency in io add file-lines --- core/io/files/files.factor | 7 ++++++- core/io/io.factor | 5 +---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3a01cc7d82..350ea1dfa6 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions -system combinators splitting ; +system combinators splitting sbufs ; HOOK: io-backend ( path -- stream ) @@ -157,3 +157,8 @@ HOOK: binary-roots io-backend ( -- seq ) PRIVATE> : walk-dir ( path -- seq ) [ (walk-dir) ] { } make ; + +: file-lines ( path -- seq ) lines ; + +: file-contents ( path -- str ) + dup swap file-length [ stream-copy ] keep >string ; diff --git a/core/io/io.factor b/core/io/io.factor index 9c5cf782e7..0336ffda78 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables generic kernel math namespaces sequences strings - continuations assocs io.files io.styles sbufs ; + continuations assocs io.styles sbufs ; IN: io GENERIC: stream-close ( stream -- ) @@ -90,6 +90,3 @@ SYMBOL: stdio : contents ( stream -- str ) 2048 [ stream-copy ] keep >string ; - -: file-contents ( path -- str ) - dup swap file-length [ stream-copy ] keep >string ;