From f657c60c4f3c235e193ce8f4931eb0f9a01fc843 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 29 Mar 2009 22:58:04 -0500 Subject: [PATCH 1/7] Some cleanup in documents.elements --- basis/documents/elements/elements.factor | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor index adb498df13..9a8b82acac 100644 --- a/basis/documents/elements/elements.factor +++ b/basis/documents/elements/elements.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators documents fry kernel math sequences -unicode.categories accessors ; +accessors unicode.categories combinators.short-circuit ; IN: documents.elements GENERIC: prev-elt ( loc document elt -- newloc ) @@ -20,14 +20,14 @@ SINGLETON: char-elt M: char-elt prev-elt - drop [ drop -1 +col ] (prev-char) ; + drop [ drop -1 +col ] prev ; M: char-elt next-elt - drop [ drop 1 +col ] (next-char) ; + drop [ drop 1 +col ] next ; SINGLETON: one-char-elt @@ -55,7 +55,7 @@ M: one-char-elt next-elt 2drop ; [ [ first2 swap ] dip doc-line ] dip call ] dip =col ; inline -: ((word-elt)) ( n seq -- n seq ? ) +: blank-at? ( n seq -- n seq ? ) 2dup ?nth blank? ; : break-detector ( ? -- quot ) @@ -65,7 +65,7 @@ M: one-char-elt next-elt 2drop ; break-detector find-last-from drop ?1+ ; : (next-word) ( col str ? -- col ) - [ break-detector find-from drop ] [ drop length ] 2bi or ; + { [ break-detector find-from drop ] [ drop length ] } 2|| ; PRIVATE> @@ -83,13 +83,13 @@ SINGLETON: word-elt M: word-elt prev-elt drop - [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ] - (prev-char) ; + [ [ [ 1- ] dip blank-at? (prev-word) ] (word-elt) ] + prev ; M: word-elt next-elt drop - [ [ ((word-elt)) (next-word) ] (word-elt) ] - (next-char) ; + [ [ blank-at? (next-word) ] (word-elt) ] + next ; SINGLETON: one-line-elt @@ -118,4 +118,4 @@ SINGLETON: doc-elt M: doc-elt prev-elt 3drop { 0 0 } ; -M: doc-elt next-elt drop nip doc-end ; \ No newline at end of file +M: doc-elt next-elt drop nip doc-end ; From 85fb4aab89d2d9940ba5e71f292f640629c7cb11 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 04:43:26 -0500 Subject: [PATCH 2/7] syndication: fix help lint --- basis/syndication/syndication-docs.factor | 2 +- basis/syndication/syndication.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/syndication/syndication-docs.factor b/basis/syndication/syndication-docs.factor index 47bdc3bb36..bc9612f55c 100644 --- a/basis/syndication/syndication-docs.factor +++ b/basis/syndication/syndication-docs.factor @@ -36,7 +36,7 @@ HELP: download-feed { $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ; HELP: parse-feed -{ $values { "sequence" "a string or a byte array" } { "feed" feed } } +{ $values { "seq" "a string or a byte array" } { "feed" feed } } { $description "Parses a feed." } ; HELP: xml>feed diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index 3bfc95fe3a..e30cd6826c 100755 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -106,7 +106,7 @@ TUPLE: entry title url description date ; { "feed" [ atom1.0 ] } } case ; -GENERIC: parse-feed ( string -- feed ) +GENERIC: parse-feed ( seq -- feed ) M: string parse-feed [ string>xml xml>feed ] with-html-entities ; From 1dfa621f4db3ccb5dafbe10c69f9e2e17869612b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 08:03:27 -0500 Subject: [PATCH 3/7] Tweak some code to reduce deployed image size --- basis/cocoa/application/application.factor | 2 +- basis/core-foundation/strings/strings.factor | 4 ++-- basis/io/encodings/ascii/ascii.factor | 6 ++---- basis/io/encodings/iana/iana.factor | 5 ++++- basis/tools/deploy/shaker/shaker.factor | 1 + 5 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 9437051dad..8b33986fc2 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax io kernel namespaces core-foundation core-foundation.strings cocoa.messages cocoa cocoa.classes -cocoa.runtime sequences threads init summary kernel.private +cocoa.runtime sequences init summary kernel.private assocs ; IN: cocoa.application diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 21f3d7efd4..413709d142 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax alien.strings io.encodings.string kernel sequences byte-arrays io.encodings.utf8 math core-foundation -core-foundation.arrays destructors unicode.data ; +core-foundation.arrays destructors ; IN: core-foundation.strings TYPEDEF: void* CFStringRef @@ -62,7 +62,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString ( : prepare-CFString ( string -- byte-array ) [ dup HEX: 10ffff > - [ drop CHAR: replacement-character ] when + [ drop HEX: fffd ] when ] map utf8 encode ; : ( string -- alien ) diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor index deb1a7121f..1654cb8b83 100644 --- a/basis/io/encodings/ascii/ascii.factor +++ b/basis/io/encodings/ascii/ascii.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.encodings kernel math io.encodings.private io.encodings.iana ; +USING: io io.encodings kernel math io.encodings.private ; IN: io.encodings.ascii n-table [ initial-e>n ] initialize [ n>e-table get-global set-at ] with each ] [ "Bad encoding registration" throw ] if* ] [ swap e>n-table get-global set-at ] 2bi ; + +ascii "ANSI_X3.4-1968" register-encoding diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 55433299ad..8ee0393091 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -157,6 +157,7 @@ IN: tools.deploy.shaker "specializer" "step-into" "step-into?" + "superclass" "transform-n" "transform-quot" "tuple-dispatch-generic" From 39b53817b948b69e8d61525a03fb20f78b970946 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 08:15:27 -0500 Subject: [PATCH 4/7] Small size reduction for deployed images --- basis/compiler/codegen/codegen.factor | 2 +- vm/callstack.c | 2 +- vm/code_block.c | 11 +++++------ vm/code_block.h | 5 ++++- vm/debug.c | 11 +++++++---- vm/quotations.c | 3 ++- 6 files changed, 20 insertions(+), 14 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 7df80c6b6e..65e70bd042 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -53,7 +53,7 @@ SYMBOL: labels V{ } clone literal-table set V{ } clone calls set compiling-word set - compiled-stack-traces? compiling-word get f ? add-literal ; + compiled-stack-traces? [ compiling-word get add-literal ] when ; : generate ( mr -- asm ) [ diff --git a/vm/callstack.c b/vm/callstack.c index d44a889756..b7e6b946bb 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -103,7 +103,7 @@ CELL frame_type(F_STACK_FRAME *frame) CELL frame_executing(F_STACK_FRAME *frame) { F_CODE_BLOCK *compiled = frame_code(frame); - if(compiled->literals == F) + if(compiled->literals == F || !stack_traces_p()) return F; else { diff --git a/vm/code_block.c b/vm/code_block.c index c6ecb2f431..8dda8bc16e 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -11,7 +11,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) { F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); - CELL index = 1; + CELL index = stack_traces_p() ? 1 : 0; F_REL *rel = (F_REL *)(relocation + 1); F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); @@ -368,11 +368,6 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format) } } -bool stack_traces_p(void) -{ - return to_boolean(userenv[STACK_TRACES_ENV]); -} - CELL compiled_code_format(void) { return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]); @@ -429,6 +424,10 @@ F_CODE_BLOCK *add_code_block( UNREGISTER_ROOT(relocation); UNREGISTER_ROOT(literals); + /* slight space optimization */ + if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0) + literals = F; + /* compiled header */ compiled->block.type = type; compiled->block.last_scan = NURSERY; diff --git a/vm/code_block.h b/vm/code_block.h index b00e4be8b6..cb8ebf5e19 100644 --- a/vm/code_block.h +++ b/vm/code_block.h @@ -75,7 +75,10 @@ void relocate_code_block(F_CODE_BLOCK *relocating); CELL compiled_code_format(void); -bool stack_traces_p(void); +INLINE bool stack_traces_p(void) +{ + return userenv[STACK_TRACES_ENV] != F; +} F_CODE_BLOCK *add_code_block( CELL type, diff --git a/vm/debug.c b/vm/debug.c index adae1cdd36..6f7e883785 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -311,7 +311,7 @@ void find_data_references(CELL look_for_) /* Dump all code blocks for debugging */ void dump_code_heap(void) { - CELL size = 0; + CELL reloc_size = 0, literal_size = 0; F_BLOCK *scan = first_block(&code_heap); @@ -324,11 +324,13 @@ void dump_code_heap(void) status = "free"; break; case B_ALLOCATED: - size += object_size(((F_CODE_BLOCK *)scan)->relocation); + reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation); + literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); status = "allocated"; break; case B_MARKED: - size += object_size(((F_CODE_BLOCK *)scan)->relocation); + reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation); + literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); status = "marked"; break; default: @@ -343,7 +345,8 @@ void dump_code_heap(void) scan = next_block(&code_heap,scan); } - print_cell(size); print_string(" bytes of relocation data\n"); + print_cell(reloc_size); print_string(" bytes of relocation data\n"); + print_cell(literal_size); print_string(" bytes of literal data\n"); } void factorbug(void) diff --git a/vm/quotations.c b/vm/quotations.c index 86e47745b7..e18e6b6098 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -180,7 +180,8 @@ void jit_compile(CELL quot, bool relocate) GROWABLE_ARRAY(literals); REGISTER_ROOT(literals); - GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F); + if(stack_traces_p()) + GROWABLE_ARRAY_ADD(literals,quot); bool stack_frame = jit_stack_frame_p(untag_object(array)); From 932d44cab8d62f2add4187ac4c3d88f98009f00e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 08:16:04 -0500 Subject: [PATCH 5/7] Small speedup for code using H{ } clone and with-scope --- .../compiler/tree/propagation/known-words/known-words.factor | 2 +- basis/hints/hints.factor | 2 +- core/hashtables/hashtables.factor | 4 ++-- core/namespaces/namespaces.factor | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index ecfd415579..1b5d383353 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -312,7 +312,7 @@ generic-comparison-ops [ \ clone [ in-d>> first value-info literal>> { { V{ } [ [ drop { } 0 vector boa ] ] } - { H{ } [ [ drop hashtable new ] ] } + { H{ } [ [ drop 0 ] ] } [ drop f ] } case ] "custom-inlining" set-word-prop diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 597367c353..804ef035f4 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -119,6 +119,6 @@ SYNTAX: HINTS: \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop -\ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop +\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop \ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 8aa13a5f5e..f95a7a7e67 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -79,7 +79,7 @@ TUPLE: hashtable : grow-hash ( hash -- ) [ [ >alist ] [ assoc-size 1+ ] bi ] keep [ reset-hash ] keep - swap (rehash) ; inline + swap (rehash) ; : ?grow-hash ( hash -- ) dup hash-large? [ @@ -95,7 +95,7 @@ TUPLE: hashtable PRIVATE> : ( n -- hash ) - hashtable new [ reset-hash ] keep ; + hashtable new [ reset-hash ] keep ; inline M: hashtable at* ( key hash -- value ? ) key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ; diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 623e2ddcda..b0e764c94d 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -30,6 +30,6 @@ PRIVATE> : bind ( ns quot -- ) swap >n call ndrop ; inline : counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ; : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline -: with-scope ( quot -- ) H{ } clone swap bind ; inline +: with-scope ( quot -- ) 5 swap bind ; inline : with-variable ( value key quot -- ) [ associate ] dip bind ; inline : initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline \ No newline at end of file From 95d9b3a417ef8e18fd3615dfb34880f680cb4213 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 31 Mar 2009 21:48:43 -0500 Subject: [PATCH 6/7] Adding functionality to unicode breaks API for future UI changes --- basis/unicode/breaks/breaks-tests.factor | 3 +++ basis/unicode/breaks/breaks.factor | 14 ++++++++++---- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor index 493c2db0c2..3a26b01213 100644 --- a/basis/unicode/breaks/breaks-tests.factor +++ b/basis/unicode/breaks/breaks-tests.factor @@ -9,6 +9,9 @@ IN: unicode.breaks.tests [ 3 ] [ "\u001112\u001161\u0011abA\u000300a" dup last-grapheme head last-grapheme ] unit-test +[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test +[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test + : grapheme-break-test ( -- filename ) "vocab:unicode/breaks/GraphemeBreakTest.txt" ; diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 12314505d9..1b1d9434f8 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -101,6 +101,16 @@ PRIVATE> [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop nip swap length or 1+ ; +: first-grapheme-from ( start str -- i ) + over tail-slice first-grapheme + ; + +: last-grapheme ( str -- i ) + unclip-last-slice grapheme-class swap + [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ; + +: last-grapheme-from ( end str -- i ) + swap head-slice last-grapheme ; + pieces ( str quot: ( str -- i ) -- graphemes ) @@ -114,10 +124,6 @@ PRIVATE> : string-reverse ( str -- rts ) >graphemes reverse concat ; -: last-grapheme ( str -- i ) - unclip-last-slice grapheme-class swap - [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ; - Date: Tue, 31 Mar 2009 21:49:14 -0500 Subject: [PATCH 7/7] left and right arrow keys move between graphemes in UI --- .../documents/elements/elements-tests.factor | 84 ++++++++++--------- basis/documents/elements/elements.factor | 32 +++---- 2 files changed, 60 insertions(+), 56 deletions(-) diff --git a/basis/documents/elements/elements-tests.factor b/basis/documents/elements/elements-tests.factor index a3f05d7a71..9b323ae8e9 100644 --- a/basis/documents/elements/elements-tests.factor +++ b/basis/documents/elements/elements-tests.factor @@ -3,68 +3,72 @@ USING: tools.test namespaces documents documents.elements multiline ; IN: document.elements.tests - "doc" set -"123\nabc" "doc" get set-doc-string +SYMBOL: doc + doc set +"123\nabcé" doc get set-doc-string ! char-elt -[ { 0 0 } ] [ { 0 0 } "doc" get char-elt prev-elt ] unit-test -[ { 0 0 } ] [ { 0 1 } "doc" get char-elt prev-elt ] unit-test -[ { 0 3 } ] [ { 1 0 } "doc" get char-elt prev-elt ] unit-test +[ { 0 0 } ] [ { 0 0 } doc get char-elt prev-elt ] unit-test +[ { 0 0 } ] [ { 0 1 } doc get char-elt prev-elt ] unit-test +[ { 0 3 } ] [ { 1 0 } doc get char-elt prev-elt ] unit-test +[ { 1 3 } ] [ { 1 5 } doc get char-elt prev-elt ] unit-test -[ { 1 3 } ] [ { 1 3 } "doc" get char-elt next-elt ] unit-test -[ { 0 2 } ] [ { 0 1 } "doc" get char-elt next-elt ] unit-test -[ { 1 0 } ] [ { 0 3 } "doc" get char-elt next-elt ] unit-test +[ { 1 5 } ] [ { 1 5 } doc get char-elt next-elt ] unit-test +[ { 0 2 } ] [ { 0 1 } doc get char-elt next-elt ] unit-test +[ { 1 0 } ] [ { 0 3 } doc get char-elt next-elt ] unit-test +[ { 1 5 } ] [ { 1 3 } doc get char-elt next-elt ] unit-test ! word-elt - "doc" set -"Hello world\nanother line" "doc" get set-doc-string + doc set +"Hello world\nanother line" doc get set-doc-string -[ { 0 0 } ] [ { 0 0 } "doc" get word-elt prev-elt ] unit-test -[ { 0 0 } ] [ { 0 2 } "doc" get word-elt prev-elt ] unit-test -[ { 0 0 } ] [ { 0 5 } "doc" get word-elt prev-elt ] unit-test -[ { 0 5 } ] [ { 0 6 } "doc" get word-elt prev-elt ] unit-test -[ { 0 6 } ] [ { 0 8 } "doc" get word-elt prev-elt ] unit-test -[ { 0 11 } ] [ { 1 0 } "doc" get word-elt prev-elt ] unit-test +[ { 0 0 } ] [ { 0 0 } doc get word-elt prev-elt ] unit-test +[ { 0 0 } ] [ { 0 2 } doc get word-elt prev-elt ] unit-test +[ { 0 0 } ] [ { 0 5 } doc get word-elt prev-elt ] unit-test +[ { 0 5 } ] [ { 0 6 } doc get word-elt prev-elt ] unit-test +[ { 0 6 } ] [ { 0 8 } doc get word-elt prev-elt ] unit-test +[ { 0 11 } ] [ { 1 0 } doc get word-elt prev-elt ] unit-test + +[ { 0 5 } ] [ { 0 0 } doc get word-elt next-elt ] unit-test +[ { 0 6 } ] [ { 0 5 } doc get word-elt next-elt ] unit-test +[ { 0 11 } ] [ { 0 6 } doc get word-elt next-elt ] unit-test +[ { 1 0 } ] [ { 0 11 } doc get word-elt next-elt ] unit-test -[ { 0 5 } ] [ { 0 0 } "doc" get word-elt next-elt ] unit-test -[ { 0 6 } ] [ { 0 5 } "doc" get word-elt next-elt ] unit-test -[ { 0 11 } ] [ { 0 6 } "doc" get word-elt next-elt ] unit-test -[ { 1 0 } ] [ { 0 11 } "doc" get word-elt next-elt ] unit-test ! one-word-elt -[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test -[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test -[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test -[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test -[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test +[ { 0 0 } ] [ { 0 0 } doc get one-word-elt prev-elt ] unit-test +[ { 0 0 } ] [ { 0 2 } doc get one-word-elt prev-elt ] unit-test +[ { 0 0 } ] [ { 0 5 } doc get one-word-elt prev-elt ] unit-test +[ { 0 5 } ] [ { 0 2 } doc get one-word-elt next-elt ] unit-test +[ { 0 5 } ] [ { 0 5 } doc get one-word-elt next-elt ] unit-test ! line-elt - "doc" set -"Hello\nworld, how are\nyou?" "doc" get set-doc-string + doc set +"Hello\nworld, how are\nyou?" doc get set-doc-string -[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test -[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test -[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test +[ { 0 0 } ] [ { 0 3 } doc get line-elt prev-elt ] unit-test +[ { 0 3 } ] [ { 1 3 } doc get line-elt prev-elt ] unit-test +[ { 2 4 } ] [ { 2 1 } doc get line-elt next-elt ] unit-test ! one-line-elt -[ { 1 0 } ] [ { 1 3 } "doc" get one-line-elt prev-elt ] unit-test -[ { 1 14 } ] [ { 1 3 } "doc" get one-line-elt next-elt ] unit-test +[ { 1 0 } ] [ { 1 3 } doc get one-line-elt prev-elt ] unit-test +[ { 1 14 } ] [ { 1 3 } doc get one-line-elt next-elt ] unit-test ! page-elt - "doc" set + doc set <" First line Second line Third line Fourth line Fifth line -Sixth line"> "doc" get set-doc-string +Sixth line"> doc get set-doc-string -[ { 0 0 } ] [ { 3 3 } "doc" get 4 prev-elt ] unit-test -[ { 1 2 } ] [ { 5 2 } "doc" get 4 prev-elt ] unit-test +[ { 0 0 } ] [ { 3 3 } doc get 4 prev-elt ] unit-test +[ { 1 2 } ] [ { 5 2 } doc get 4 prev-elt ] unit-test -[ { 4 3 } ] [ { 0 3 } "doc" get 4 next-elt ] unit-test -[ { 5 10 } ] [ { 4 2 } "doc" get 4 next-elt ] unit-test +[ { 4 3 } ] [ { 0 3 } doc get 4 next-elt ] unit-test +[ { 5 10 } ] [ { 4 2 } doc get 4 next-elt ] unit-test ! doc-elt -[ { 0 0 } ] [ { 3 4 } "doc" get doc-elt prev-elt ] unit-test -[ { 5 10 } ] [ { 3 4 } "doc" get doc-elt next-elt ] unit-test \ No newline at end of file +[ { 0 0 } ] [ { 3 4 } doc get doc-elt prev-elt ] unit-test +[ { 5 10 } ] [ { 3 4 } doc get doc-elt next-elt ] unit-test diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor index 9a8b82acac..f485f1bec1 100644 --- a/basis/documents/elements/elements.factor +++ b/basis/documents/elements/elements.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators documents fry kernel math sequences -accessors unicode.categories combinators.short-circuit ; +accessors unicode.categories unicode.breaks combinators.short-circuit ; IN: documents.elements GENERIC: prev-elt ( loc document elt -- newloc ) @@ -27,20 +27,25 @@ SINGLETON: char-elt [ call ] } cond ; inline -: next ( loc document quot: ( loc document -- loc ) +: next ( loc document quot: ( loc document -- loc ) -- loc ) { { [ 2over doc-end = ] [ 2drop ] } { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] } [ call ] } cond ; inline +: modify-col ( loc document quot: ( col str -- col' ) -- loc ) + pick [ + [ [ first2 swap ] dip doc-line ] dip call + ] dip =col ; inline + PRIVATE> M: char-elt prev-elt - drop [ drop -1 +col ] prev ; + drop [ [ last-grapheme-from ] modify-col ] prev ; M: char-elt next-elt - drop [ drop 1 +col ] next ; + drop [ [ first-grapheme-from ] modify-col ] next ; SINGLETON: one-char-elt @@ -50,22 +55,17 @@ M: one-char-elt next-elt 2drop ; @@ -73,22 +73,22 @@ SINGLETON: one-word-elt M: one-word-elt prev-elt drop - [ [ 1- ] dip f (prev-word) ] (word-elt) ; + [ [ 1- ] dip f prev-word ] modify-col ; M: one-word-elt next-elt drop - [ f (next-word) ] (word-elt) ; + [ f next-word ] modify-col ; SINGLETON: word-elt M: word-elt prev-elt drop - [ [ [ 1- ] dip blank-at? (prev-word) ] (word-elt) ] + [ [ [ 1- ] dip blank-at? prev-word ] modify-col ] prev ; M: word-elt next-elt drop - [ [ blank-at? (next-word) ] (word-elt) ] + [ [ blank-at? next-word ] modify-col ] next ; SINGLETON: one-line-elt