From 4a01649d15669a474a964bcc544adb7900d4f651 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 13 Jan 2009 00:05:19 -0600 Subject: [PATCH 1/7] add with-directory-entries and file-type>trailing --- basis/io/directories/directories-docs.factor | 5 ++ basis/io/directories/directories.factor | 3 + basis/io/files/info/unix/unix.factor | 68 +++++++++++++------- 3 files changed, 52 insertions(+), 24 deletions(-) diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index edfcf480b0..a469f5b816 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -50,6 +50,10 @@ HELP: with-directory-files { $values { "path" "a pathname string" } { "quot" quotation } } { $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; +HELP: with-directory-entries +{ $values { "path" "a pathname string" } { "quot" quotation } } +{ $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; + HELP: delete-file { $values { "path" "a pathname string" } } { $description "Deletes a file." } @@ -122,6 +126,7 @@ ARTICLE: "io.directories.listing" "Directory listing" "Directory listing:" { $subsection directory-entries } { $subsection directory-files } +{ $subsection with-directory-entries } { $subsection with-directory-files } ; ARTICLE: "io.directories.create" "Creating directories" diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor index 2630be8ce2..6ae55b7f7b 100755 --- a/basis/io/directories/directories.factor +++ b/basis/io/directories/directories.factor @@ -41,6 +41,9 @@ HOOK: (directory-entries) os ( path -- seq ) : directory-files ( path -- seq ) directory-entries [ name>> ] map ; +: with-directory-entries ( path quot -- ) + '[ "" directory-entries @ ] with-directory ; inline + : with-directory-files ( path quot -- ) '[ "" directory-files @ ] with-directory ; inline diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 9287e7f4ad..b7edc14c2c 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -114,30 +114,6 @@ M: file-info file-mode? [ permissions>> ] dip mask? ; PRIVATE> -: ch>file-type ( ch -- type ) - { - { CHAR: b [ +block-device+ ] } - { CHAR: c [ +character-device+ ] } - { CHAR: d [ +directory+ ] } - { CHAR: l [ +symbolic-link+ ] } - { CHAR: s [ +socket+ ] } - { CHAR: p [ +fifo+ ] } - { CHAR: - [ +regular-file+ ] } - [ drop +unknown+ ] - } case ; - -: file-type>ch ( type -- string ) - { - { +block-device+ [ CHAR: b ] } - { +character-device+ [ CHAR: c ] } - { +directory+ [ CHAR: d ] } - { +symbolic-link+ [ CHAR: l ] } - { +socket+ [ CHAR: s ] } - { +fifo+ [ CHAR: p ] } - { +regular-file+ [ CHAR: - ] } - [ drop CHAR: - ] - } case ; - : UID OCT: 0004000 ; inline : GID OCT: 0002000 ; inline : STICKY OCT: 0001000 ; inline @@ -251,3 +227,47 @@ M: string set-file-group ( path string -- ) : file-group-name ( path -- string ) file-group-id group-name ; + +: ch>file-type ( ch -- type ) + { + { CHAR: b [ +block-device+ ] } + { CHAR: c [ +character-device+ ] } + { CHAR: d [ +directory+ ] } + { CHAR: l [ +symbolic-link+ ] } + { CHAR: s [ +socket+ ] } + { CHAR: p [ +fifo+ ] } + { CHAR: - [ +regular-file+ ] } + [ drop +unknown+ ] + } case ; + +: file-type>ch ( type -- ch ) + { + { +block-device+ [ CHAR: b ] } + { +character-device+ [ CHAR: c ] } + { +directory+ [ CHAR: d ] } + { +symbolic-link+ [ CHAR: l ] } + { +socket+ [ CHAR: s ] } + { +fifo+ [ CHAR: p ] } + { +regular-file+ [ CHAR: - ] } + [ drop CHAR: - ] + } case ; + +executable ( directory-entry -- string ) + name>> any-execute? "*" "" ? ; + +PRIVATE> + +: file-type>trailing ( directory-entry -- string ) + dup type>> + { + { +directory+ [ drop "/" ] } + { +symbolic-link+ [ drop "@" ] } + { +fifo+ [ drop "|" ] } + { +socket+ [ drop "=" ] } + { +whiteout+ [ drop "%" ] } + { +unknown+ [ file-type>executable ] } + { +regular-file+ [ file-type>executable ] } + [ drop file-type>executable ] + } case ; From f920007959292abed2c89fbaafea594e86ec4cb8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 13 Jan 2009 00:20:34 -0600 Subject: [PATCH 2/7] extend sort-by-slots to work with nested objects, add split-by-slots for already-sorted sequences of tuples --- basis/sorting/slots/slots-docs.factor | 13 ++- basis/sorting/slots/slots-tests.factor | 105 +++++++++++++++++++++++-- basis/sorting/slots/slots.factor | 21 +++-- 3 files changed, 126 insertions(+), 13 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index 64d0a1efdf..a3bdbf9ac1 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -6,17 +6,17 @@ IN: sorting.slots HELP: compare-slots { $values - { "sort-specs" "a sequence of accessor/comparator pairs" } + { "sort-specs" "a sequence of accessors ending with a comparator" } { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } } { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; HELP: sort-by-slots { $values - { "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" } + { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } { "seq'" sequence } } -{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." } +{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $examples "Sort by slot c, then b descending:" { $example @@ -32,6 +32,13 @@ HELP: sort-by-slots } } ; +HELP: split-by-slots +{ $values + { "accessor-seqs" "a sequence of sequences of tuple accessors" } + { "quot" quotation } +} +{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ; + ARTICLE: "sorting.slots" "Sorting by slots" "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl "Comparing two objects by a sequence of slots:" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index ab130d1eed..7a4eeb8e75 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math.order sorting.slots tools.test -sorting.human ; +sorting.human arrays sequences kernel assocs multiline ; IN: sorting.literals.tests -TUPLE: sort-test a b c ; +TUPLE: sort-test a b c tuple2 ; + +TUPLE: tuple2 d ; [ { @@ -43,8 +45,101 @@ TUPLE: sort-test a b c ; ] unit-test [ - { } + { + { + T{ sort-test { a 1 } { b 1 } { c 10 } } + T{ sort-test { a 1 } { b 1 } { c 11 } } + } + { T{ sort-test { a 1 } { b 3 } { c 9 } } } + { + T{ sort-test { a 2 } { b 5 } { c 3 } } + T{ sort-test { a 2 } { b 5 } { c 2 } } + } + } ] [ - { } - { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots + { + T{ sort-test f 1 3 9 } + T{ sort-test f 1 1 10 } + T{ sort-test f 1 1 11 } + T{ sort-test f 2 5 3 } + T{ sort-test f 2 5 2 } + } + { { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep + [ but-last-slice ] map split-by-slots [ >array ] map +] unit-test + +: split-test ( seq -- seq' ) + { { a>> } { b>> } } split-by-slots ; + +[ split-test ] must-infer + +[ { } ] +[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test + +[ + { + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } } + T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } + } +] [ + { + T{ sort-test f 6 f f T{ tuple2 f 1 } } + T{ sort-test f 5 f f T{ tuple2 f 4 } } + T{ sort-test f 6 f f T{ tuple2 f 3 } } + T{ sort-test f 6 f f T{ tuple2 f 3 } } + T{ sort-test f 5 f f T{ tuple2 f 3 } } + T{ sort-test f 6 f f T{ tuple2 f 2 } } + } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots +] unit-test + +[ + { + { + T{ sort-test + { a 6 } + { tuple2 T{ tuple2 { d 1 } } } + } + } + { + T{ sort-test + { a 6 } + { tuple2 T{ tuple2 { d 2 } } } + } + } + { + T{ sort-test + { a 5 } + { tuple2 T{ tuple2 { d 3 } } } + } + } + { + T{ sort-test + { a 6 } + { tuple2 T{ tuple2 { d 3 } } } + } + T{ sort-test + { a 6 } + { tuple2 T{ tuple2 { d 3 } } } + } + } + { + T{ sort-test + { a 5 } + { tuple2 T{ tuple2 { d 4 } } } + } + } + } +] [ + { + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } } + T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } + } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map ] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 02a11428f9..56b6a115f0 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -1,19 +1,30 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.short-circuit fry kernel macros math.order -sequences words sorting ; +sequences words sorting sequences.deep assocs splitting.monotonic +math ; IN: sorting.slots MACRO: compare-slots ( sort-specs -- <=> ) - #! sort-spec: { accessor comparator } - [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ; + #! sort-spec: { accessors comparator } + [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; : sort-by-slots ( seq sort-specs -- seq' ) '[ _ compare-slots ] sort ; + +MACRO: split-by-slots ( accessor-seqs -- quot ) + [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map + '[ [ _ 2&& ] slice monotonic-slice ] ; From 16c067e71a1f69e601b11f0048bceb92d686cbe5 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 13 Jan 2009 10:29:27 +0100 Subject: [PATCH 3/7] FUEL: Bug fix. --- extra/fuel/help/help.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 298124ffb4..ff7239ac8f 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -95,7 +95,7 @@ PRIVATE> [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline : (fuel-word-def) ( name -- str ) - fuel-find-word [ [ def>> pprint ] with-string-writer ] when* ; inline + fuel-find-word [ [ def>> pprint ] with-string-writer ] [ f ] if* ; inline : (fuel-vocab-summary) ( name -- str ) >vocab-link summary ; inline From 7e751b4195c6279cdee4cf9dc880bed2f9fa2e50 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 13 Jan 2009 11:57:59 +0100 Subject: [PATCH 4/7] FUEL: Fix the fix to multiline string literals font-lock. --- misc/fuel/fuel-syntax.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 7f0fa313c2..b74b0afc11 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -94,7 +94,7 @@ "\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>") (defconst fuel-syntax--bad-string-regex - "\"[^\"]*$") + "\"\\([^\"]\\|\\\\\"\\)*\n") (defconst fuel-syntax--word-definition-regex (fuel-syntax--second-word-regex @@ -226,7 +226,7 @@ ;; CHARs: ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w")) ;; Strings - ("\\(\"\\)[^\n\r\f]*\\(\"\\)" (1 "\"") (2 "\"")) + ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\\"?\\)*\\(\"\\)" (1 "\"") (3 "\"")) ;; Let and lambda: ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]")) From 5fbfc1acf1ad56959d342bb2b1f73a464ed5f4c5 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 13 Jan 2009 16:34:28 +0100 Subject: [PATCH 5/7] Remove duplicate inverse definition --- extra/inverse/inverse.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index a38af644b0..b9e0788192 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -148,7 +148,6 @@ MACRO: undo ( quot -- ) [undo] ; \ exp [ log ] define-inverse \ log [ exp ] define-inverse -\ not [ not ] define-inverse \ sq [ sqrt ] define-inverse \ sqrt [ sq ] define-inverse From 280564b6ecd6321dbf1d2a5615b09d61d8e52dbe Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 13 Jan 2009 16:39:34 +0100 Subject: [PATCH 6/7] Define reciprocal inverses with "define-dual" --- extra/inverse/inverse-docs.factor | 7 ++++++- extra/inverse/inverse-tests.factor | 3 +++ extra/inverse/inverse.factor | 15 +++++++-------- 3 files changed, 16 insertions(+), 9 deletions(-) diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor index 8204f7174c..c2615fc411 100644 --- a/extra/inverse/inverse-docs.factor +++ b/extra/inverse/inverse-docs.factor @@ -14,7 +14,12 @@ HELP: undo HELP: define-inverse { $values { "word" "a word" } { "quot" "the inverse" } } { $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." } -{ $see-also define-pop-inverse } ; +{ $see-also define-dual define-pop-inverse } ; + +HELP: define-dual +{ $values { "word1" "a word" } { "word2" "a word" } } +{ $description "Defines the inverse of each word as being the other one." } +{ $see-also define-inverse } ; HELP: define-pop-inverse { $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } } diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 5e662ed78f..3dce620857 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -75,3 +75,6 @@ C: nil [ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test [ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail [ { 1 2 3 } [ { 2 3 } prepend ] undo ] must-fail + +[ [ sq ] ] [ [ sqrt ] [undo] ] unit-test +[ [ sqrt ] ] [ [ sq ] [undo] ] unit-test diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index b9e0788192..ec4df1ba69 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -20,6 +20,9 @@ M: fail summary drop "Matching failed" ; : define-inverse ( word quot -- ) "inverse" set-word-prop ; +: define-dual ( word1 word2 -- ) + 2dup swap [ 1quotation define-inverse ] 2bi@ ; + : define-math-inverse ( word quot1 quot2 -- ) pick 1quotation 3array "math-inverse" set-word-prop ; @@ -139,17 +142,14 @@ MACRO: undo ( quot -- ) [undo] ; \ not [ not ] define-inverse \ >boolean [ { t f } memq? assure ] define-inverse -\ tuple>array [ >tuple ] define-inverse -\ >tuple [ tuple>array ] define-inverse +\ tuple>array \ >tuple define-dual \ reverse [ reverse ] define-inverse \ undo 1 [ [ call ] curry ] define-pop-inverse \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse -\ exp [ log ] define-inverse -\ log [ exp ] define-inverse -\ sq [ sqrt ] define-inverse -\ sqrt [ sq ] define-inverse +\ exp \ log define-dual +\ sq \ sqrt define-dual ERROR: missing-literal ; @@ -203,8 +203,7 @@ DEFER: _ \ first3 [ 3array ] define-inverse \ first4 [ 4array ] define-inverse -\ prefix [ unclip ] define-inverse -\ unclip [ prefix ] define-inverse +\ prefix \ unclip define-dual \ suffix [ dup but-last swap peek ] define-inverse \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse From dccb72befef2081e5e3a59c63d3b5cd5955d8c7d Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 13 Jan 2009 16:58:31 +0100 Subject: [PATCH 7/7] Define involutary words with "define-involution" --- extra/inverse/inverse-docs.factor | 9 +++++++-- extra/inverse/inverse-tests.factor | 2 ++ extra/inverse/inverse.factor | 8 +++++--- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor index c2615fc411..6b575d6d08 100644 --- a/extra/inverse/inverse-docs.factor +++ b/extra/inverse/inverse-docs.factor @@ -14,12 +14,17 @@ HELP: undo HELP: define-inverse { $values { "word" "a word" } { "quot" "the inverse" } } { $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." } -{ $see-also define-dual define-pop-inverse } ; +{ $see-also define-dual define-involution define-pop-inverse } ; HELP: define-dual { $values { "word1" "a word" } { "word2" "a word" } } { $description "Defines the inverse of each word as being the other one." } -{ $see-also define-inverse } ; +{ $see-also define-inverse define-involution } ; + +HELP: define-involution +{ $values { "word" "a word" } } +{ $description "Defines a word as being its own inverse." } +{ $see-also define-dual define-inverse } ; HELP: define-pop-inverse { $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } } diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 3dce620857..a9234fcff4 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -78,3 +78,5 @@ C: nil [ [ sq ] ] [ [ sqrt ] [undo] ] unit-test [ [ sqrt ] ] [ [ sq ] [undo] ] unit-test +[ [ not ] ] [ [ not ] [undo] ] unit-test +[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index ec4df1ba69..924a6d3814 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -23,6 +23,8 @@ M: fail summary drop "Matching failed" ; : define-dual ( word1 word2 -- ) 2dup swap [ 1quotation define-inverse ] 2bi@ ; +: define-involution ( word -- ) dup 1quotation define-inverse ; + : define-math-inverse ( word quot1 quot2 -- ) pick 1quotation 3array "math-inverse" set-word-prop ; @@ -132,18 +134,18 @@ MACRO: undo ( quot -- ) [undo] ; ! Inverse of selected words -\ swap [ swap ] define-inverse +\ swap define-involution \ dup [ [ =/fail ] keep ] define-inverse \ 2dup [ over =/fail over =/fail ] define-inverse \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse \ pick [ [ pick ] dip =/fail ] define-inverse \ tuck [ swapd [ =/fail ] keep ] define-inverse -\ not [ not ] define-inverse +\ not define-involution \ >boolean [ { t f } memq? assure ] define-inverse \ tuple>array \ >tuple define-dual -\ reverse [ reverse ] define-inverse +\ reverse define-involution \ undo 1 [ [ call ] curry ] define-pop-inverse \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse