From 2e796f84310ec681d9f0f6e9f62d1c30d68abb81 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Tue, 6 May 2008 16:26:20 -0500
Subject: [PATCH 1/3] Interval maps made more efficient
---
extra/interval-maps/interval-maps.factor | 30 ++++++++++++++----------
extra/unicode/breaks/breaks.factor | 0
2 files changed, 17 insertions(+), 13 deletions(-)
mode change 100644 => 100755 extra/unicode/breaks/breaks.factor
diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
index 7dcb9466cc..bc46fd986b 100755
--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@@ -1,36 +1,40 @@
-USING: kernel sequences arrays math.intervals accessors
+USING: kernel sequences arrays accessors
math.order sorting math assocs locals namespaces ;
IN: interval-maps
TUPLE: interval-map array ;
<PRIVATE
-TUPLE: interval-node interval value ;
+TUPLE: interval-node from to value ;
+: range ( node -- from to ) [ from>> ] [ to>> ] bi ;
: fixup-value ( value ? -- value/f ? )
[ drop f f ] unless* ;
: find-interval ( key interval-map -- i )
- [ interval>> from>> first <=> ] binsearch ;
+ [ from>> <=> ] binsearch ;
-GENERIC: >interval ( object -- interval )
-M: number >interval [a,a] ;
-M: sequence >interval first2 [a,b] ;
-M: interval >interval ;
+GENERIC: >interval ( object -- 2array )
+M: number >interval dup 2array ;
+M: sequence >interval ;
: all-intervals ( sequence -- intervals )
[ >r >interval r> ] assoc-map ;
+: disjoint? ( node1 node2 -- ? )
+ [ to>> ] [ from>> ] bi* < ;
+
: ensure-disjoint ( intervals -- intervals )
- dup keys [ interval-intersect not ] monotonic?
+ dup [ disjoint? ] monotonic?
[ "Intervals are not disjoint" throw ] unless ;
-
+: interval-contains? ( object interval-node -- ? )
+ range between? ;
PRIVATE>
: interval-at* ( key map -- value ? )
array>> [ find-interval ] 2keep swapd nth
- [ nip value>> ] [ interval>> interval-contains? ] 2bi
+ [ nip value>> ] [ interval-contains? ] 2bi
fixup-value ;
: interval-at ( key map -- value ) interval-at* drop ;
@@ -38,9 +42,9 @@ PRIVATE>
: <interval-map> ( specification -- map )
all-intervals { } assoc-like
- [ [ first to>> ] compare ] sort ensure-disjoint
- [ interval-node boa ] { } assoc>map
- interval-map boa ;
+ [ [ first second ] compare ] sort
+ [ >r first2 r> interval-node boa ] { } assoc>map
+ ensure-disjoint interval-map boa ;
:: coalesce ( alist -- specification )
! Only works with integer keys, because they're discrete
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
old mode 100644
new mode 100755
From c04da7bdfb0874515ee146e96cda042e0c63b00a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Tue, 6 May 2008 20:59:37 -0500
Subject: [PATCH 2/3] unicode.syntax.backend => value (with docs &c)
---
extra/io/encodings/iana/iana.factor | 6 ++---
extra/unicode/breaks/breaks.factor | 4 +--
extra/unicode/data/data.factor | 2 +-
extra/unicode/script/script.factor | 2 +-
extra/values/authors.txt | 1 +
extra/values/summary.txt | 1 +
extra/values/tags.txt | 1 +
extra/values/values-docs.factor | 27 +++++++++++++++++++
extra/values/values-tests.factor | 9 +++++++
.../backend.factor => values/values.factor} | 8 +++++-
10 files changed, 53 insertions(+), 8 deletions(-)
mode change 100644 => 100755 extra/io/encodings/iana/iana.factor
create mode 100755 extra/values/authors.txt
create mode 100755 extra/values/summary.txt
create mode 100755 extra/values/tags.txt
create mode 100755 extra/values/values-docs.factor
create mode 100755 extra/values/values-tests.factor
rename extra/{unicode/syntax/backend/backend.factor => values/values.factor} (52%)
mode change 100644 => 100755
diff --git a/extra/io/encodings/iana/iana.factor b/extra/io/encodings/iana/iana.factor
old mode 100644
new mode 100755
index 24badaf683..dd429c1670
--- a/extra/io/encodings/iana/iana.factor
+++ b/extra/io/encodings/iana/iana.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings unicode.syntax.backend io.files assocs
-splitting sequences io namespaces sets
-io.encodings.ascii io.encodings.utf8 io.encodings.utf16 io.encodings.8-bit ;
+USING: kernel strings values io.files assocs
+splitting sequences io namespaces sets io.encodings.8-bit
+io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
IN: io.encodings.iana
<PRIVATE
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index d8e4f8c24e..3787f78648 100755
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,7 +1,7 @@
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
-math.ranges unicode.normalize unicode.syntax.backend
-unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
+math.ranges unicode.normalize values io.encodings.ascii
+unicode.syntax unicode.data compiler.units alien.syntax ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 85ce50acb9..d630aacbed 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,7 +1,7 @@
USING: assocs math kernel sequences io.files hashtables
quotations splitting arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii unicode.syntax.backend ;
+io.encodings.ascii values ;
IN: unicode.data
! Convenience functions
diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor
index d0bb4ac30d..846f797f71 100755
--- a/extra/unicode/script/script.factor
+++ b/extra/unicode/script/script.factor
@@ -1,4 +1,4 @@
-USING: unicode.syntax.backend kernel sequences assocs io.files
+USING: values kernel sequences assocs io.files
io.encodings ascii math.ranges io splitting math.parser
namespaces byte-arrays locals math sets io.encodings.ascii
words compiler.units arrays interval-maps ;
diff --git a/extra/values/authors.txt b/extra/values/authors.txt
new file mode 100755
index 0000000000..504363d316
--- /dev/null
+++ b/extra/values/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/extra/values/summary.txt b/extra/values/summary.txt
new file mode 100755
index 0000000000..7caab7412d
--- /dev/null
+++ b/extra/values/summary.txt
@@ -0,0 +1 @@
+Global variables in the Forth value style
diff --git a/extra/values/tags.txt b/extra/values/tags.txt
new file mode 100755
index 0000000000..187b6926c1
--- /dev/null
+++ b/extra/values/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/extra/values/values-docs.factor b/extra/values/values-docs.factor
new file mode 100755
index 0000000000..4984b03f03
--- /dev/null
+++ b/extra/values/values-docs.factor
@@ -0,0 +1,27 @@
+USING: help.markup help.syntax ;
+IN: values
+
+ARTICLE: "values" "Global values"
+"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. Values abstract over this concept. To create a new word as a value, use the following syntax:"
+{ $subsection POSTPONE: VALUE: }
+"To get the value, just call the word. The following words manipulate values:"
+{ $subsection get-value }
+{ $subsection set-value }
+{ $subsection change-value } ;
+
+HELP: VALUE:
+{ $syntax "VALUE: word" }
+{ $values { "word" "a word to be created" } }
+{ $description "Creates a value on the given word, initializing it to hold " { $code f } ". To get the value, just run the word. To set it, use " { $link set-value } "." } ;
+
+HELP: get-value
+{ $values { "word" "a value word" } { "value" "the contents" } }
+{ $description "Gets a value. This should not normally be used, unless the word is not known until runtime." } ;
+
+HELP: set-value
+{ $values { "value" "a new value" } { "word" "a value word" } }
+{ $description "Sets the value word." } ;
+
+HELP: change-value
+{ $values { "word" "a value word" } { "quot" "a quotation ( oldvalue -- newvalue )" } }
+{ $description "Changes the value using the given quotation." } ;
diff --git a/extra/values/values-tests.factor b/extra/values/values-tests.factor
new file mode 100755
index 0000000000..31b44be99e
--- /dev/null
+++ b/extra/values/values-tests.factor
@@ -0,0 +1,9 @@
+USING: tools.test values math ;
+IN: values.tests
+
+VALUE: foo
+[ f ] [ foo ] unit-test
+[ ] [ 3 \ foo set-value ] unit-test
+[ 3 ] [ foo ] unit-test
+[ ] [ \ foo [ 1+ ] change-value ] unit-test
+[ 4 ] [ foo ] unit-test
diff --git a/extra/unicode/syntax/backend/backend.factor b/extra/values/values.factor
old mode 100644
new mode 100755
similarity index 52%
rename from extra/unicode/syntax/backend/backend.factor
rename to extra/values/values.factor
index 5c463e8fc4..0d1ea3bc04
--- a/extra/unicode/syntax/backend/backend.factor
+++ b/extra/values/values.factor
@@ -1,8 +1,14 @@
USING: kernel parser sequences words ;
-IN: unicode.syntax.backend
+IN: values
: VALUE:
CREATE-WORD { f } clone [ first ] curry define ; parsing
: set-value ( value word -- )
word-def first set-first ;
+
+: get-value ( word -- value )
+ word-def first first ;
+
+: change-value ( word quot -- )
+ over >r >r get-value r> call r> set-value ; inline
From 1005e5e9395aa3406f1742c404fa318c75b79158 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Fri, 9 May 2008 15:42:02 -0500
Subject: [PATCH 3/3] Minor refactoring in lcs and interval-maps
---
extra/interval-maps/interval-maps.factor | 22 ++++++++++------------
extra/lcs/lcs.factor | 9 ++++-----
2 files changed, 14 insertions(+), 17 deletions(-)
diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
index bc46fd986b..904b76ce94 100755
--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@@ -1,4 +1,4 @@
-USING: kernel sequences arrays accessors
+USING: kernel sequences arrays accessors tuple-arrays
math.order sorting math assocs locals namespaces ;
IN: interval-maps
@@ -6,7 +6,6 @@ TUPLE: interval-map array ;
<PRIVATE
TUPLE: interval-node from to value ;
-: range ( node -- from to ) [ from>> ] [ to>> ] bi ;
: fixup-value ( value ? -- value/f ? )
[ drop f f ] unless* ;
@@ -14,12 +13,12 @@ TUPLE: interval-node from to value ;
: find-interval ( key interval-map -- i )
[ from>> <=> ] binsearch ;
-GENERIC: >interval ( object -- 2array )
-M: number >interval dup 2array ;
-M: sequence >interval ;
+: interval-contains? ( object interval-node -- ? )
+ [ from>> ] [ to>> ] bi between? ;
: all-intervals ( sequence -- intervals )
- [ >r >interval r> ] assoc-map ;
+ [ >r dup number? [ dup 2array ] when r> ] assoc-map
+ { } assoc-like ;
: disjoint? ( node1 node2 -- ? )
[ to>> ] [ from>> ] bi* < ;
@@ -28,8 +27,8 @@ M: sequence >interval ;
dup [ disjoint? ] monotonic?
[ "Intervals are not disjoint" throw ] unless ;
-: interval-contains? ( object interval-node -- ? )
- range between? ;
+: >intervals ( specification -- intervals )
+ [ >r first2 r> interval-node boa ] { } assoc>map ;
PRIVATE>
: interval-at* ( key map -- value ? )
@@ -41,10 +40,9 @@ PRIVATE>
: interval-key? ( key map -- ? ) interval-at* nip ;
: <interval-map> ( specification -- map )
- all-intervals { } assoc-like
- [ [ first second ] compare ] sort
- [ >r first2 r> interval-node boa ] { } assoc>map
- ensure-disjoint interval-map boa ;
+ all-intervals [ [ first second ] compare ] sort
+ >intervals ensure-disjoint >tuple-array
+ interval-map boa ;
:: coalesce ( alist -- specification )
! Only works with integer keys, because they're discrete
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
index cdebfc4325..e5155a786e 100755
--- a/extra/lcs/lcs.factor
+++ b/extra/lcs/lcs.factor
@@ -7,7 +7,7 @@ IN: lcs
0 1 ? + >r [ 1+ ] bi@ r> min min ;
: lcs-step ( insert delete change same? -- next )
- 1 -9999 ? + max max ; ! Replace -9999 with -inf when added
+ 1 -1./0. ? + max max ; ! -1./0. is -inf (float)
:: loop-step ( i j matrix old new step -- )
i j 1+ matrix nth nth ! insertion
@@ -25,10 +25,9 @@ IN: lcs
:: run-lcs ( old new init step -- matrix )
[let | matrix [ old length 1+ new length 1+ init call ] |
- old length [0,b) [| i |
- new length [0,b)
- [| j | i j matrix old new step loop-step ]
- each
+ old length [| i |
+ new length
+ [| j | i j matrix old new step loop-step ] each
] each matrix ] ; inline
PRIVATE>