From 6d0d6ac80a6d9ff58cc0a591d329b65163272c1a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 21 Nov 2007 23:56:50 -0600 Subject: [PATCH 01/30] 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 f0903db414437dfdcecd7c13c2d1c729c31f9ff3 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 22 Dec 2007 01:25:01 +0100 Subject: [PATCH 02/30] 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 03/30] 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 04/30] 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 05/30] 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 85a5beed74b5578eb9558c9a85711779284d806c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 24 Dec 2007 13:20:52 -0500 Subject: [PATCH 06/30] 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 5917e58c8698b8386b24db298c405f48cc2437f9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 24 Dec 2007 20:48:29 -0500 Subject: [PATCH 07/30] 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 d5baea215d3e886315ec2738d01a02615a4d49c7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 25 Dec 2007 02:28:55 -0500 Subject: [PATCH 08/30] 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 aaa4b2a62f4aae6fe1759b11cf44e59db8eb2cd4 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 26 Dec 2007 20:35:35 +0100 Subject: [PATCH 09/30] 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 10/30] 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 11/30] 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 12/30] 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 13/30] 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 14/30] 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 15/30] 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 16/30] 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 17/30] 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 18/30] 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 19/30] 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 20/30] 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 21/30] 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 8a562bc81fe5a427c20a1ee4488256af1b24d713 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Dec 2007 20:16:55 -0500 Subject: [PATCH 22/30] 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 23/30] 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 24/30] 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 25/30] 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 26/30] 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 27/30] 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 28/30] 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 fe2ef1e41839c1711993b6552a1b1a9dfec93eb1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 30 Dec 2007 04:21:03 -0500 Subject: [PATCH 29/30] 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 30/30] 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" } }