From ba61b8215275bb6ea605169d291f133b8d5db711 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 7 Apr 2009 21:47:57 -0500
Subject: [PATCH 01/33] Pass vocab roots onto deployed app. Fixes deployment of
apps outside the built-in roots. Reported by Alec Berryman
---
basis/command-line/command-line.factor | 1 -
basis/tools/deploy/backend/backend.factor | 4 ++--
2 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor
index 73a01aa352..56d7fbd207 100644
--- a/basis/command-line/command-line.factor
+++ b/basis/command-line/command-line.factor
@@ -60,7 +60,6 @@ SYMBOL: main-vocab-hook
: default-cli-args ( -- )
global [
"quiet" off
- "script" off
"e" off
"user-init" on
embedded? "quiet" set
diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor
index 28a32790dc..6ca54ca36b 100755
--- a/basis/tools/deploy/backend/backend.factor
+++ b/basis/tools/deploy/backend/backend.factor
@@ -8,7 +8,7 @@ debugger io.streams.c io.files io.files.temp io.pathnames
io.directories io.directories.hierarchy io.backend quotations
io.launcher words.private tools.deploy.config
tools.deploy.config.editor bootstrap.image io.encodings.utf8
-destructors accessors ;
+destructors accessors hashtables ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name -- vm )
@@ -88,7 +88,7 @@ DEFER: ?make-staging-image
[ drop ] [ make-staging-image ] if ;
: make-deploy-config ( vocab -- file )
- [ deploy-config unparse-use ]
+ [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
[ "deploy-config-" prepend temp-file ] bi
[ utf8 set-file-contents ] keep ;
From 6082a98c7c075dbfc03d9a3c720e0fcccfda4eb5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 7 Apr 2009 22:30:13 -0500
Subject: [PATCH 02/33] If (open-window) or similar fails, don't enter an
infinite loop of opening error windows, just try to open one and then give up
---
basis/ui/ui.factor | 31 +++++++++++++++++--------------
1 file changed, 17 insertions(+), 14 deletions(-)
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index bf17e455f8..dff7726d08 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make dlists
deques sequences threads sequences words continuations init
-combinators hashtables concurrency.flags sets accessors calendar fry
-destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render ;
+combinators combinators.short-circuit hashtables concurrency.flags
+sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
IN: ui
<PRIVATE
@@ -117,12 +117,10 @@ M: world ungraft*
gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
: update-ui ( -- )
- [
- notify-queued
- layout-queued
- redraw-worlds
- send-queued-gestures
- ] [ ui-error ] recover ;
+ notify-queued
+ layout-queued
+ redraw-worlds
+ send-queued-gestures ;
SYMBOL: ui-thread
@@ -133,8 +131,7 @@ SYMBOL: ui-thread
PRIVATE>
: find-window ( quot -- world )
- windows get values
- [ gadget-child swap call ] with find-last nip ; inline
+ [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
@@ -142,9 +139,15 @@ PRIVATE>
<PRIVATE
: update-ui-loop ( -- )
- [ ui-running? ui-thread get-global self eq? and ]
- [ ui-notify-flag get lower-flag update-ui ]
- while ;
+ #! Note the logic: if update-ui fails, we open an error window
+ #! and run one iteration of update-ui. If that also fails, well,
+ #! the whole UI subsystem is broken so we exit out of the
+ #! update-ui-loop.
+ [ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
+ [
+ ui-notify-flag get lower-flag
+ [ update-ui ] [ ui-error update-ui ] recover
+ ] while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
From ee9f509e82e29c80572ac61f4bae9d7c30958596 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 8 Apr 2009 02:41:02 -0400
Subject: [PATCH 03/33] Solutions to Project Euler problem 69
---
extra/project-euler/007/007.factor | 3 -
extra/project-euler/069/069-tests.factor | 4 ++
extra/project-euler/069/069.factor | 87 ++++++++++++++++++++++++
extra/project-euler/071/071.factor | 7 --
extra/project-euler/common/common.factor | 19 ++++--
extra/project-euler/project-euler.factor | 16 ++---
6 files changed, 113 insertions(+), 23 deletions(-)
create mode 100644 extra/project-euler/069/069-tests.factor
create mode 100644 extra/project-euler/069/069.factor
diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor
index f9208e11b3..1827d0fa06 100644
--- a/extra/project-euler/007/007.factor
+++ b/extra/project-euler/007/007.factor
@@ -17,9 +17,6 @@ IN: project-euler.007
! SOLUTION
! --------
-: nth-prime ( n -- n )
- 1- lprimes lnth ;
-
: euler007 ( -- answer )
10001 nth-prime ;
diff --git a/extra/project-euler/069/069-tests.factor b/extra/project-euler/069/069-tests.factor
new file mode 100644
index 0000000000..97741c0ee3
--- /dev/null
+++ b/extra/project-euler/069/069-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.069 tools.test ;
+
+{ 510510 } [ euler069 ] unit-test
+{ 510510 } [ euler069a ] unit-test
diff --git a/extra/project-euler/069/069.factor b/extra/project-euler/069/069.factor
new file mode 100644
index 0000000000..eae1d82ece
--- /dev/null
+++ b/extra/project-euler/069/069.factor
@@ -0,0 +1,87 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel math math.primes math.primes.factors math.ranges
+ project-euler.common sequences ;
+IN: project-euler.069
+
+! http://projecteuler.net/index.php?section=problems&id=69
+
+! DESCRIPTION
+! -----------
+
+! Euler's Totient function, φ(n) [sometimes called the phi function], is used
+! to determine the number of numbers less than n which are relatively prime to
+! n. For example, as 1, 2, 4, 5, 7, and 8, are all less than nine and
+! relatively prime to nine, φ(9)=6.
+
+! +----+------------------+------+-----------+
+! | n | Relatively Prime | φ(n) | n / φ(n) |
+! +----+------------------+------+-----------+
+! | 2 | 1 | 1 | 2 |
+! | 3 | 1,2 | 2 | 1.5 |
+! | 4 | 1,3 | 2 | 2 |
+! | 5 | 1,2,3,4 | 4 | 1.25 |
+! | 6 | 1,5 | 2 | 3 |
+! | 7 | 1,2,3,4,5,6 | 6 | 1.1666... |
+! | 8 | 1,3,5,7 | 4 | 2 |
+! | 9 | 1,2,4,5,7,8 | 6 | 1.5 |
+! | 10 | 1,3,7,9 | 4 | 2.5 |
+! +----+------------------+------+-----------+
+
+! It can be seen that n = 6 produces a maximum n / φ(n) for n ≤ 10.
+
+! Find the value of n ≤ 1,000,000 for which n / φ(n) is a maximum.
+
+
+! SOLUTION
+! --------
+
+! Brute force
+
+<PRIVATE
+
+: totient-ratio ( n -- m )
+ dup totient / ;
+
+PRIVATE>
+
+: euler069 ( -- answer )
+ 2 1000000 [a,b] [ totient-ratio ] map
+ [ supremum ] keep index 2 + ;
+
+! [ euler069 ] 10 ave-time
+! 25210 ms ave run time - 115.37 SD (10 trials)
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+! In order to obtain maximum n / φ(n), φ(n) needs to be low and n needs to be
+! high. Hence we need a number that has the most factors. A number with the
+! most unique factors would have fewer relatively prime.
+
+<PRIVATE
+
+: primorial ( n -- m )
+ {
+ { [ dup 0 = ] [ drop V{ 1 } ] }
+ { [ dup 1 = ] [ drop V{ 2 } ] }
+ [ nth-prime primes-upto ]
+ } cond product ;
+
+: (primorial-upto) ( count limit -- m )
+ '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
+ nip penultimate ;
+
+: primorial-upto ( limit -- m )
+ 1 swap (primorial-upto) ;
+
+PRIVATE>
+
+: euler069a ( -- answer )
+ 1000000 primorial-upto ;
+
+! [ euler069a ] 100 ave-time
+! 0 ms ave run time - 0.01 SD (100 trials)
+
+SOLUTION: euler069a
diff --git a/extra/project-euler/071/071.factor b/extra/project-euler/071/071.factor
index cccf6bf708..0fd93a8f2d 100644
--- a/extra/project-euler/071/071.factor
+++ b/extra/project-euler/071/071.factor
@@ -32,13 +32,6 @@ IN: project-euler.071
! repeatedly until the denominator is as close to 1000000 as possible without
! going over.
-<PRIVATE
-
-: penultimate ( seq -- elt )
- dup length 2 - swap nth ;
-
-PRIVATE>
-
: euler071 ( -- answer )
2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] produce
nip penultimate numerator ;
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index ba8c81fbf4..c2ffe26d94 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,9 +1,10 @@
-! Copyright (c) 2007-2008 Aaron Schaefer.
+! Copyright (c) 2007-2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel make math math.functions math.matrices math.miller-rabin
- math.order math.parser math.primes.factors math.ranges math.ratios
- sequences sorting strings unicode.case parser accessors vocabs.parser
- namespaces vocabs words quotations prettyprint ;
+USING: accessors arrays kernel lists make math math.functions math.matrices
+ math.miller-rabin math.order math.parser math.primes.factors
+ math.primes.lists math.ranges math.ratios namespaces parser prettyprint
+ quotations sequences sorting strings unicode.case vocabs vocabs.parser
+ words ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
@@ -16,11 +17,13 @@ IN: project-euler.common
! log10 - #25, #134
! max-path - #18, #67
! mediant - #71, #73
+! nth-prime - #7, #69
! nth-triangle - #12, #42
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
! palindrome? - #4, #36, #55
! pandigital? - #32, #38
! pentagonal? - #44, #45
+! penultimate - #69, #71
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12
@@ -78,6 +81,9 @@ PRIVATE>
: number-length ( n -- m )
log10 floor 1+ >integer ;
+: nth-prime ( n -- n )
+ 1- lprimes lnth ;
+
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
@@ -90,6 +96,9 @@ PRIVATE>
: pentagonal? ( n -- ? )
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
+: penultimate ( seq -- elt )
+ dup length 2 - swap nth ;
+
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- new-triangle )
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 5d46d7f1fd..95d3644215 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007, 2008, 2009 Aaron Schaefer, Samuel Tardieu.
+! Copyright (c) 2007-2009 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files io.pathnames kernel math math.parser
prettyprint project-euler.ave-time sequences vocabs vocabs.loader
@@ -16,13 +16,13 @@ USING: definitions io io.files io.pathnames kernel math math.parser
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.049 project-euler.052 project-euler.053 project-euler.054
project-euler.055 project-euler.056 project-euler.057 project-euler.058
- project-euler.059 project-euler.063 project-euler.067 project-euler.071
- project-euler.073 project-euler.075 project-euler.076 project-euler.079
- project-euler.092 project-euler.097 project-euler.099 project-euler.100
- project-euler.116 project-euler.117 project-euler.134 project-euler.148
- project-euler.150 project-euler.151 project-euler.164 project-euler.169
- project-euler.173 project-euler.175 project-euler.186 project-euler.190
- project-euler.203 project-euler.215 ;
+ project-euler.059 project-euler.063 project-euler.067 project-euler.069
+ project-euler.071 project-euler.073 project-euler.075 project-euler.076
+ project-euler.079 project-euler.092 project-euler.097 project-euler.099
+ project-euler.100 project-euler.116 project-euler.117 project-euler.134
+ project-euler.148 project-euler.150 project-euler.151 project-euler.164
+ project-euler.169 project-euler.173 project-euler.175 project-euler.186
+ project-euler.190 project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE
From d3b5236367f34361e9aca2a8d5d7c3d532f31239 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 8 Apr 2009 05:04:58 -0500
Subject: [PATCH 04/33] Fix poker tests
---
extra/poker/poker-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor
index 1862974084..ad371a6bff 100644
--- a/extra/poker/poker-tests.factor
+++ b/extra/poker/poker-tests.factor
@@ -1,4 +1,4 @@
-USING: accessors poker poker.private tools.test ;
+USING: accessors poker poker.private tools.test math.order kernel ;
IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test
From 30191f87e5d06749a4c8c0c317a5ad09ad8381cc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 8 Apr 2009 05:13:06 -0500
Subject: [PATCH 05/33] descriptive: add make-descriptive word to enable this
functionality to be used as an annotation; improve docs
---
extra/descriptive/descriptive-docs.factor | 22 +++++++++++++++-------
extra/descriptive/descriptive.factor | 11 +++++++++--
2 files changed, 24 insertions(+), 9 deletions(-)
diff --git a/extra/descriptive/descriptive-docs.factor b/extra/descriptive/descriptive-docs.factor
index dc02f8bd9d..6ced201c13 100755
--- a/extra/descriptive/descriptive-docs.factor
+++ b/extra/descriptive/descriptive-docs.factor
@@ -1,20 +1,28 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup words ;
IN: descriptive
HELP: DESCRIPTIVE:
{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }
-{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
+{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
HELP: DESCRIPTIVE::
{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }
-{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
+{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
-HELP: descriptive
-{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
+HELP: descriptive-error
+{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
+
+HELP: make-descriptive
+{ $values { "word" word } }
+{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;
ARTICLE: "descriptive" "Descriptive errors"
-"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"
-{ $subsection descriptive }
+"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:"
+{ $subsection descriptive-error }
+"The wrapper contains the word itself, the input parameters, as well as the original error."
+$nl
+"To annotate an existing word with descriptive error checking:"
+{ $subsection make-descriptive }
"To define words which throw descriptive errors, use the following words:"
{ $subsection POSTPONE: DESCRIPTIVE: }
{ $subsection POSTPONE: DESCRIPTIVE:: } ;
diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor
index ceadc9fe6e..9af94aa4ed 100755
--- a/extra/descriptive/descriptive.factor
+++ b/extra/descriptive/descriptive.factor
@@ -1,6 +1,9 @@
-USING: words kernel sequences locals locals.parser
+! Copyright (c) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel sequences locals locals.parser fry
locals.definitions accessors parser namespaces continuations
-summary definitions generalizations arrays prettyprint debugger io ;
+summary definitions generalizations arrays prettyprint debugger io
+effects tools.annotations ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
@@ -23,6 +26,10 @@ M: descriptive-error error.
PRIVATE>
+: make-descriptive ( word -- )
+ dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
+ '[ drop _ ] annotate-methods ;
+
: define-descriptive ( word def effect -- )
[ drop "descriptive-definition" set-word-prop ]
[ [ [ dup ] 2dip [descriptive] ] keep define-declared ]
From 94baa7d7fa084ffed47aa1e2240b268c9e6ef8f7 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Wed, 8 Apr 2009 18:12:27 -0500
Subject: [PATCH 06/33] Call ScriptStringOut with ETO_OPAQUE
---
basis/windows/uniscribe/uniscribe.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
index 7cfda41dc9..f6cacfb683 100755
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -59,10 +59,10 @@ TUPLE: script-string font string metrics ssa size image disposed ;
ssa>> ! ssa
0 ! iX
0 ! iY
- 0 ! uOptions
- f ! prc
+ ETO_OPAQUE ! uOptions
]
- [ selection-start/end ] bi
+ [ [ { 0 0 } ] dip size>> <RECT> ]
+ [ selection-start/end ] tri
! iMinSel
! iMaxSel
FALSE ! fDisabled
@@ -108,7 +108,7 @@ M: script-string dispose*
SYMBOL: cached-script-strings
-: cached-script-string ( string font -- script-string )
+: cached-script-string ( font string -- script-string )
cached-script-strings get-global [ <script-string> ] 2cache ;
[ <cache-assoc> cached-script-strings set-global ]
From 49852f57153cd24e23912d8b4efd7c00a4e86f3a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 8 Apr 2009 18:42:01 -0500
Subject: [PATCH 07/33] fix saving bitmaps
---
basis/images/bitmap/bitmap-tests.factor | 28 +++++++++++-
basis/images/bitmap/bitmap.factor | 60 +++++++++++++++----------
2 files changed, 62 insertions(+), 26 deletions(-)
diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor
index e154df26a1..c7012cfd42 100644
--- a/basis/images/bitmap/bitmap-tests.factor
+++ b/basis/images/bitmap/bitmap-tests.factor
@@ -1,6 +1,6 @@
USING: images.bitmap images.viewer io.encodings.binary
io.files io.files.unique kernel tools.test images.loader
-literals sequences ;
+literals sequences checksums.md5 checksums ;
IN: images.bitmap.tests
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
@@ -11,6 +11,11 @@ CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
+CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp"
+CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
+CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
+CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
+
[ t ]
[
test-bitmap24
@@ -24,4 +29,23 @@ CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
$ test-bitmap8
$ test-bitmap24
"vocab:ui/render/test/reference.bmp"
-} [ [ ] swap [ load-image drop ] curry unit-test ] each
\ No newline at end of file
+} [ [ ] swap [ load-image drop ] curry unit-test ] each
+
+
+: test-bitmap-save ( path -- ? )
+ [ md5 checksum-file ]
+ [ load-image ] bi
+ "bitmap-save-test" unique-file
+ [ save-bitmap ]
+ [ md5 checksum-file ] bi = ;
+
+[
+ t
+] [
+ {
+ $ test-40
+ $ test-41
+ $ test-42
+ $ test-43
+ } [ test-bitmap-save ] all?
+] unit-test
diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index 8209159a8e..48095bb26b 100755
--- a/basis/images/bitmap/bitmap.factor
+++ b/basis/images/bitmap/bitmap.factor
@@ -37,14 +37,14 @@ M: bitmap-magic summary
ERROR: bmp-not-supported n ;
: reverse-lines ( byte-array width -- byte-array )
- 3 * <sliced-groups> <reversed> concat ; inline
+ <sliced-groups> <reversed> concat ; inline
: raw-bitmap>seq ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
- { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
- { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
+ { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
+ { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
[ bmp-not-supported ]
} case >byte-array ;
@@ -81,30 +81,31 @@ ERROR: bmp-not-supported n ;
: image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
+: bitmap-padding ( width -- n )
+ 3 * 4 mod 4 swap - 4 mod ; inline
+
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
loading-bitmap width>> :> width
width 3 * :> width*3
- loading-bitmap height>> abs :> height
- loading-bitmap color-index>> length :> color-index-length
- color-index-length height /i :> stride
- color-index-length width*3 height * - height /i :> padding
+ loading-bitmap width>> bitmap-padding :> padding
+ loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
+ loading-bitmap
padding 0 > [
- loading-bitmap [
+ [
stride <sliced-groups>
[ width*3 head-slice ] map concat
] change-color-index
- ] [
- loading-bitmap
- ] if ;
+ ] when ;
: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index
fixup-color-index ;
-: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
- [ binary ] dip '[
- _ parse-file-header parse-bitmap-header parse-bitmap
+: load-bitmap-data ( path -- loading-bitmap )
+ binary [
+ loading-bitmap new
+ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
ERROR: unknown-component-order bitmap ;
@@ -117,8 +118,7 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
-: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
- [ bitmap-image new ] dip
+: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
{
[ raw-bitmap>seq >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
@@ -127,20 +127,30 @@ ERROR: unknown-component-order bitmap ;
} cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
- drop loading-bitmap new
- load-bitmap-data
- loading-bitmap>bitmap-image ;
+ swap load-bitmap-data loading-bitmap>bitmap-image ;
PRIVATE>
-: bitmap>color-index ( bitmap-array -- byte-array )
- 4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
+: bitmap>color-index ( bitmap -- byte-array )
+ [
+ bitmap>>
+ 4 <sliced-groups>
+ [ 3 head-slice <reversed> ] map
+ B{ } join
+ ] [
+ dim>> first dup bitmap-padding dup 0 > [
+ [ 3 * group ] dip '[ _ <byte-array> append ] map
+ B{ } join
+ ] [
+ 2drop
+ ] if
+ ] bi ;
: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write
[
- bitmap>> bitmap>color-index length 14 + 40 + write4
+ bitmap>color-index length 14 + 40 + write4
0 write4
54 write4
40 write4
@@ -159,7 +169,7 @@ PRIVATE>
[ drop 0 write4 ]
! size-image
- [ bitmap>> bitmap>color-index length write4 ]
+ [ bitmap>color-index length write4 ]
! x-pels
[ drop 0 write4 ]
@@ -175,7 +185,9 @@ PRIVATE>
! rgb-quads
[
- [ bitmap>> bitmap>color-index ] [ dim>> first ] bi
+ [ bitmap>color-index ]
+ [ dim>> first 3 * ]
+ [ dim>> first bitmap-padding + ] tri
reverse-lines write
]
} cleave
From 07cf80f0a8b1c1c105e4a7eb89263bfb3fb48e4b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 8 Apr 2009 18:42:26 -0500
Subject: [PATCH 08/33] fix stack effect for unique-file
---
basis/io/files/unique/unique-docs.factor | 2 +-
basis/io/files/unique/unique.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor
index 74fc045032..6a7be47813 100644
--- a/basis/io/files/unique/unique-docs.factor
+++ b/basis/io/files/unique/unique-docs.factor
@@ -62,8 +62,8 @@ HELP: current-temporary-directory
HELP: unique-file
{ $values
+ { "prefix" string }
{ "path" "a pathname string" }
- { "path'" "a pathname string" }
}
{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ;
diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor
index 7bd96aa63b..0e4338e3e0 100644
--- a/basis/io/files/unique/unique.factor
+++ b/basis/io/files/unique/unique.factor
@@ -64,7 +64,7 @@ PRIVATE>
[ unique-directory ] dip
'[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
-: unique-file ( path -- path' )
+: unique-file ( prefix -- path )
"" make-unique-file ;
{
From 694652590f22787357e3c6c71c453a5b0643b257 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Apr 2009 08:18:26 -0500
Subject: [PATCH 09/33] download word throneeds to ws an error if the request
did not return a success code (reported by Chris Double)
---
basis/http/client/client.factor | 2 +-
basis/http/http-tests.factor | 5 ++++-
2 files changed, 5 insertions(+), 2 deletions(-)
diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 805929d27b..307fdd5031 100644
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -165,7 +165,7 @@ ERROR: download-failed response ;
present file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
- binary [ [ write ] with-http-get drop ] with-file-writer ;
+ binary [ [ write ] with-http-get check-response drop ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor
index da50a6f85f..45ad132677 100644
--- a/basis/http/http-tests.factor
+++ b/basis/http/http-tests.factor
@@ -392,4 +392,7 @@ SYMBOL: a
[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
-[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
\ No newline at end of file
+! Check that download throws errors (reported by Chris Double)
+[ "http://localhost/tweet_my_twat" add-port download ] must-fail
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
From 9efa1e0c3126a4faca3748743407d8dc3de3fc5d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Apr 2009 08:23:05 -0500
Subject: [PATCH 10/33] Don't use glTexSubImage2D unless we really have to
---
basis/opengl/textures/textures.factor | 14 +++++++++-----
1 file changed, 9 insertions(+), 5 deletions(-)
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index e13e99e10f..1900deb5b8 100755
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -36,10 +36,12 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
[ next-power-of-2 ] map
] unless ;
-: (tex-image) ( image -- )
- [ GL_TEXTURE_2D 0 GL_RGBA ] dip
- [ dim>> adjust-texture-dim first2 0 ]
- [ component-order>> component-order>format f ] bi
+: (tex-image) ( image bitmap -- )
+ [
+ [ GL_TEXTURE_2D 0 GL_RGBA ] dip
+ [ dim>> adjust-texture-dim first2 0 ]
+ [ component-order>> component-order>format ] bi
+ ] dip
glTexImage2D ;
: (tex-sub-image) ( image -- )
@@ -53,7 +55,9 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
- [ (tex-image) ] [ (tex-sub-image) ] bi
+ non-power-of-2-textures? get
+ [ dup bitmap>> (tex-image) ]
+ [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
] do-attribs
] keep ;
From 1551eacfa2cd47972bbe5e084a82ded6a2b92fbd Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.(none)>
Date: Thu, 9 Apr 2009 10:44:50 -0500
Subject: [PATCH 11/33] add support for tiff grayscale images
---
basis/images/bitmap/bitmap-tests.factor | 15 ++++-----------
basis/images/images.factor | 5 +++--
basis/images/loader/loader.factor | 5 ++---
basis/images/tiff/tiff.factor | 3 ++-
basis/opengl/textures/textures.factor | 4 +++-
basis/windows/uniscribe/uniscribe.factor | 10 +++++-----
6 files changed, 19 insertions(+), 23 deletions(-)
diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor
index c7012cfd42..29ba3b9b80 100644
--- a/basis/images/bitmap/bitmap-tests.factor
+++ b/basis/images/bitmap/bitmap-tests.factor
@@ -1,6 +1,7 @@
USING: images.bitmap images.viewer io.encodings.binary
io.files io.files.unique kernel tools.test images.loader
-literals sequences checksums.md5 checksums ;
+literals sequences checksums.md5 checksums
+images.normalization ;
IN: images.bitmap.tests
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
@@ -16,15 +17,6 @@ CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
-[ t ]
-[
- test-bitmap24
- [ binary file-contents ] [ load-image ] bi
-
- "test-bitmap24" unique-file
- [ save-bitmap ] [ binary file-contents ] bi =
-] unit-test
-
{
$ test-bitmap8
$ test-bitmap24
@@ -34,7 +26,7 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
: test-bitmap-save ( path -- ? )
[ md5 checksum-file ]
- [ load-image ] bi
+ [ load-image normalize-image ] bi
"bitmap-save-test" unique-file
[ save-bitmap ]
[ md5 checksum-file ] bi = ;
@@ -47,5 +39,6 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
$ test-41
$ test-42
$ test-43
+ $ test-bitmap24
} [ test-bitmap-save ] all?
] unit-test
diff --git a/basis/images/images.factor b/basis/images/images.factor
index b32953f67c..178b91ab52 100755
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -3,7 +3,7 @@
USING: combinators kernel accessors ;
IN: images
-SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
@@ -11,6 +11,7 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
: bytes-per-pixel ( component-order -- n )
{
{ L [ 1 ] }
+ { LA [ 2 ] }
{ BGR [ 3 ] }
{ RGB [ 3 ] }
{ BGRA [ 4 ] }
@@ -33,4 +34,4 @@ TUPLE: image dim component-order upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
-GENERIC: load-image* ( path tuple -- image )
\ No newline at end of file
+GENERIC: load-image* ( path tuple -- image )
diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor
index b8bafc021f..fe33cc8f00 100644
--- a/basis/images/loader/loader.factor
+++ b/basis/images/loader/loader.factor
@@ -1,8 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images images.normalization
-io.pathnames ;
+accessors images.bitmap images.tiff images io.pathnames ;
IN: images.loader
ERROR: unknown-image-extension extension ;
@@ -16,4 +15,4 @@ ERROR: unknown-image-extension extension ;
} case ;
: load-image ( path -- image )
- dup image-class new load-image* normalize-image ;
+ dup image-class new load-image* ;
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index 80eaff8140..381cd70d22 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -463,6 +463,7 @@ ERROR: unknown-component-order ifd ;
{ { 16 16 16 } [ 2 seq>native-endianness ] }
{ { 8 8 8 8 } [ ] }
{ { 8 8 8 } [ ] }
+ { 8 [ ] }
[ unknown-component-order ]
} case >>bitmap ;
@@ -474,11 +475,11 @@ ERROR: unknown-component-order ifd ;
{ { 16 16 16 } [ R16G16B16 ] }
{ { 8 8 8 8 } [ RGBA ] }
{ { 8 8 8 } [ RGB ] }
+ { 8 [ L ] }
[ unknown-component-order ]
} case ;
: normalize-alpha-data ( seq -- byte-array )
- ! [ normalize-alpha-data ] change-bitmap
B{ } like dup
byte-array>float-array
4 <sliced-groups>
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index e13e99e10f..fdf21c32c2 100755
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -20,6 +20,8 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ;
+M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ;
SLOT: display-list
@@ -159,4 +161,4 @@ PRIVATE>
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
- [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
\ No newline at end of file
+ [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
index f6cacfb683..fb0c134b9a 100755
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math sequences fry io.encodings.string
-io.encodings.utf16n accessors arrays combinators destructors locals
-cache namespaces init images.normalization fonts alien.c-types
-windows windows.usp10 windows.offscreen windows.gdi32
-windows.ole32 windows.types windows.fonts opengl.textures ;
+io.encodings.utf16n accessors arrays combinators destructors
+cache namespaces init fonts alien.c-types windows windows.usp10
+windows.offscreen windows.gdi32 windows.ole32 windows.types
+windows.fonts opengl.textures locals ;
IN: windows.uniscribe
TUPLE: script-string font string metrics ssa size image disposed ;
@@ -112,4 +112,4 @@ SYMBOL: cached-script-strings
cached-script-strings get-global [ <script-string> ] 2cache ;
[ <cache-assoc> cached-script-strings set-global ]
-"windows.uniscribe" add-init-hook
\ No newline at end of file
+"windows.uniscribe" add-init-hook
From 5279bb0efc67e22ebba3b2e8b09ac713e504b0f1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.(none)>
Date: Thu, 9 Apr 2009 10:46:43 -0500
Subject: [PATCH 12/33] change L to LA for grayscale tiffs
---
basis/images/tiff/tiff.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index 381cd70d22..6bf1ea2ff1 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -475,7 +475,7 @@ ERROR: unknown-component-order ifd ;
{ { 16 16 16 } [ R16G16B16 ] }
{ { 8 8 8 8 } [ RGBA ] }
{ { 8 8 8 } [ RGB ] }
- { 8 [ L ] }
+ { 8 [ LA ] }
[ unknown-component-order ]
} case ;
From cdc3d1b643053a17c16e7b177ada4a242c2db179 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 9 Apr 2009 15:03:34 -0500
Subject: [PATCH 13/33] more id3 refactoring, support TAG+
---
extra/id3/id3-docs.factor | 28 +++----
extra/id3/id3.factor | 166 ++++++++++++++++++++++++--------------
2 files changed, 121 insertions(+), 73 deletions(-)
diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor
index feb110fab8..c43559a630 100644
--- a/extra/id3/id3-docs.factor
+++ b/extra/id3/id3-docs.factor
@@ -7,7 +7,7 @@ IN: id3
HELP: mp3>id3
{ $values
{ "path" "a path string" }
- { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
+ { "id3/f" "a tuple storing ID3v2 metadata or f" } }
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
{ $list
{ $link title }
@@ -22,49 +22,49 @@ HELP: mp3>id3
HELP: album
{ $values
- { "id3" id3v2-info }
- { "album/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: artist
{ $values
- { "id3" id3v2-info }
- { "artist/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: comment
{ $values
- { "id3" id3v2-info }
- { "comment/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: genre
{ $values
- { "id3" id3v2-info }
- { "genre/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: title
{ $values
- { "id3" id3v2-info }
- { "title/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: year
{ $values
- { "id3" id3v2-info }
- { "year/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: find-id3-frame
{ $values
- { "id3" id3v2-info } { "name" string }
+ { "id3" id3 } { "name" string }
{ "obj/f" "object or f" }
}
{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor
index 5076a4a8ab..8a235d305d 100644
--- a/extra/id3/id3.factor
+++ b/extra/id3/id3.factor
@@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search ;
+io.directories.search literals ;
IN: id3
<PRIVATE
@@ -37,47 +37,68 @@ CONSTANT: genres
"Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
"Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
"Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
- "Euro-House" "Dance Hall"
+ "Euro-House" "Dance Hall" "Goa" "Drum & Bass" "Club-House"
+ "Hardcore" "Terror" "Indie" "BritPop" "Negerpunk"
+ "Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
+ "Black Metal" "Crossover" "Contemporary Christian"
+ "Christian Rock"
}
TUPLE: header version flags size ;
-TUPLE: frame frame-id flags size data ;
+TUPLE: frame tag flags size data ;
-TUPLE: id3v2-info header frames ;
+TUPLE: id3 header frames
+title artist album year comment genre
+speed genre-name start-time end-time ;
-TUPLE: id3v1-info title artist album year comment genre ;
-
-: <id3v1-info> ( -- object ) id3v1-info new ; inline
-
-: <id3v2-info> ( header frames -- object )
- [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
+: <id3> ( -- id3 )
+ id3 new
+ H{ } clone >>frames ; inline
: <header> ( -- object ) header new ; inline
: <frame> ( -- object ) frame new ; inline
-: id3v2? ( mmap -- ? ) "ID3" head? ; inline
+: id3v2? ( seq -- ? ) "ID3" head? ; inline
-: id3v1? ( mmap -- ? )
- { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
+CONSTANT: id3v1-length 128
+CONSTANT: id3v1-offset 128
+CONSTANT: id3v1+-length 227
+CONSTANT: id3v1+-offset $[ 128 227 + ]
-: id3v1-frame ( string key -- frame )
- <frame>
- swap >>frame-id
- swap >>data ; inline
+: id3v1? ( seq -- ? )
+ {
+ [ length id3v1-offset >= ]
+ [ id3v1-length tail-slice* "TAG" head? ]
+ } 1&& ; inline
-: id3v1>id3v2 ( id3v1 -- id3v2 )
+: id3v1+? ( seq -- ? )
+ {
+ [ length id3v1+-offset >= ]
+ [ id3v1+-length tail-slice* "TAG+" head? ]
+ } 1&& ; inline
+
+: pair>frame ( string key -- frame/f )
+ over [
+ <frame>
+ swap >>tag
+ swap >>data
+ ] [
+ 2drop f
+ ] if ; inline
+
+: id3v1>frames ( id3v1 -- seq )
[
{
- [ title>> "TIT2" id3v1-frame ]
- [ artist>> "TPE1" id3v1-frame ]
- [ album>> "TALB" id3v1-frame ]
- [ year>> "TYER" id3v1-frame ]
- [ comment>> "COMM" id3v1-frame ]
- [ genre>> "TCON" id3v1-frame ]
+ [ title>> "TIT2" pair>frame ]
+ [ artist>> "TPE1" pair>frame ]
+ [ album>> "TALB" pair>frame ]
+ [ year>> "TYER" pair>frame ]
+ [ comment>> "COMM" pair>frame ]
+ [ genre>> "TCON" pair>frame ]
} cleave
- ] output>array f swap <id3v2-info> ; inline
+ ] output>array sift ;
: >28bitword ( seq -- int )
0 [ [ 7 shift ] dip bitor ] reduce ; inline
@@ -85,10 +106,10 @@ TUPLE: id3v1-info title artist album year comment genre ;
: filter-text-data ( data -- filtered )
[ printable? ] filter ; inline
-: valid-frame-id? ( id -- ? )
+: valid-tag? ( id -- ? )
[ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
-: read-frame-data ( frame mmap -- frame data )
+: read-frame-data ( frame seq -- frame data )
[ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
: decode-text ( string -- string' )
@@ -96,28 +117,29 @@ TUPLE: id3v1-info title artist album year comment genre ;
{ { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
utf16 ascii ? decode ; inline
-: (read-frame) ( mmap -- frame )
+: (read-frame) ( seq -- frame )
[ <frame> ] dip
{
- [ 4 head-slice decode-text >>frame-id ]
+ [ 4 head-slice decode-text >>tag ]
[ [ 4 8 ] dip subseq >28bitword >>size ]
[ [ 8 10 ] dip subseq >byte-array >>flags ]
[ read-frame-data decode-text >>data ]
} cleave ; inline
-: read-frame ( mmap -- frame/f )
- dup 4 head-slice valid-frame-id?
+: read-frame ( seq -- frame/f )
+ dup 4 head-slice valid-tag?
[ (read-frame) ] [ drop f ] if ; inline
-: remove-frame ( mmap frame -- mmap )
+: remove-frame ( seq frame -- seq )
size>> 10 + tail-slice ; inline
-: read-frames ( mmap -- frames )
- [ dup read-frame dup ]
- [ [ remove-frame ] keep ]
- produce 2nip ; inline
+: frames>assoc ( seq -- assoc )
+ [ [ tag>> ] keep ] H{ } map>assoc ; inline
+
+: read-frames ( seq -- assoc )
+ [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ; inline
-: read-v2-header ( seq -- id3header )
+: read-v2-header ( seq -- header )
[ <header> ] dip
{
[ [ 3 5 ] dip <slice> >array >>version ]
@@ -125,15 +147,18 @@ TUPLE: id3v1-info title artist album year comment genre ;
[ [ 6 10 ] dip <slice> >28bitword >>size ]
} cleave ; inline
-: read-v2-tag-data ( seq -- id3v2-info )
- 10 cut-slice
- [ read-v2-header ]
- [ read-frames ] bi* <id3v2-info> ; inline
-
-: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
+: merge-frames ( id3 assoc -- id3 )
+ [ dup frames>> ] dip update ; inline
-: (read-v1-tag-data) ( seq -- mp3-file )
- [ <id3v1-info> ] dip
+: merge-id3v1 ( id3 -- id3 )
+ dup id3v1>frames frames>assoc merge-frames ; inline
+
+: read-v2-tags ( id3 seq -- id3 )
+ 10 cut-slice
+ [ read-v2-header >>header ]
+ [ read-frames frames>assoc merge-frames ] bi* ; inline
+
+: extract-v1-tags ( id3 seq -- id3 )
{
[ 30 head-slice decode-text filter-text-data >>title ]
[ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
@@ -143,8 +168,30 @@ TUPLE: id3v1-info title artist album year comment genre ;
[ [ 124 ] dip nth number>string >>genre ]
} cleave ; inline
-: read-v1-tag-data ( seq -- mp3-file )
- skip-to-v1-data (read-v1-tag-data) ; inline
+: read-v1-tags ( id3 seq -- id3 )
+ id3v1-offset tail-slice* 3 tail-slice
+ extract-v1-tags ; inline
+
+: extract-v1+-tags ( id3 seq -- id3 )
+ {
+ [ 60 head-slice decode-text filter-text-data [ append ] change-title ]
+ [
+ [ 60 120 ] dip subseq decode-text filter-text-data
+ [ append ] change-artist
+ ]
+ [
+ [ 120 180 ] dip subseq decode-text filter-text-data
+ [ append ] change-album
+ ]
+ [ [ 180 ] dip nth >>speed ]
+ [ [ 181 211 ] dip subseq decode-text >>genre-name ]
+ [ [ 211 217 ] dip subseq decode-text >>start-time ]
+ [ [ 217 223 ] dip subseq decode-text >>end-time ]
+ } cleave ; inline
+
+: read-v1+-tags ( id3 seq -- id3 )
+ id3v1+-offset tail-slice* 4 tail-slice
+ extract-v1+-tags ; inline
: parse-genre ( string -- n/f )
dup "(" ?head-slice drop ")" ?tail-slice drop
@@ -154,34 +201,35 @@ TUPLE: id3v1-info title artist album year comment genre ;
drop
] if ; inline
-: (mp3>id3) ( path -- id3v2-info/f )
+: (mp3>id3) ( path -- id3v2/f )
[
+ [ <id3> ] dip
{
- { [ dup id3v2? ] [ read-v2-tag-data ] }
- { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
- [ drop f ]
- } cond
+ [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
+ } cleave
] with-mapped-uchar-file ;
PRIVATE>
-: mp3>id3 ( path -- id3v2-info/f )
+: mp3>id3 ( path -- id3/f )
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
: find-id3-frame ( id3 name -- obj/f )
swap frames>> at* [ data>> ] when ; inline
-: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
+: title ( id3 -- string/f ) "TIT2" find-id3-frame ; inline
-: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
+: artist ( id3 -- string/f ) "TPE1" find-id3-frame ; inline
-: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
+: album ( id3 -- string/f ) "TALB" find-id3-frame ; inline
-: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
+: year ( id3 -- string/f ) "TYER" find-id3-frame ; inline
-: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
+: comment ( id3 -- string/f ) "COMM" find-id3-frame ; inline
-: genre ( id3 -- genre/f )
+: genre ( id3 -- string/f )
"TCON" find-id3-frame parse-genre ; inline
: find-mp3s ( path -- seq )
From 6583b4d38e1c82baa1742fdd931b1e90b64a78a4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 9 Apr 2009 15:28:48 -0500
Subject: [PATCH 14/33] rename html.parser.state to sequence-parser
---
extra/c/preprocessor/preprocessor.factor | 2 +-
extra/html/parser/parser.factor | 2 +-
extra/html/parser/state/state-tests.factor | 104 --------------
extra/html/parser/state/state.factor | 127 ------------------
extra/html/parser/utils/utils.factor | 4 +-
.../sequence-parser-tests.factor | 104 ++++++++++++++
extra/sequence-parser/sequence-parser.factor | 126 +++++++++++++++++
7 files changed, 234 insertions(+), 235 deletions(-)
delete mode 100644 extra/html/parser/state/state-tests.factor
delete mode 100644 extra/html/parser/state/state.factor
create mode 100644 extra/sequence-parser/sequence-parser-tests.factor
create mode 100644 extra/sequence-parser/sequence-parser.factor
diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor
index f7cd10a0e9..e5029ca683 100644
--- a/extra/c/preprocessor/preprocessor.factor
+++ b/extra/c/preprocessor/preprocessor.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: html.parser.state io io.encodings.utf8 io.files
+USING: sequence-parser io io.encodings.utf8 io.files
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 61315a4925..b1dc4de4df 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables html.parser.state
+USING: accessors arrays hashtables sequence-parser
html.parser.utils kernel namespaces sequences
unicode.case unicode.categories combinators.short-circuit
quoting fry ;
diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
deleted file mode 100644
index c8a8a95892..0000000000
--- a/extra/html/parser/state/state-tests.factor
+++ /dev/null
@@ -1,104 +0,0 @@
-USING: tools.test html.parser.state ascii kernel accessors ;
-IN: html.parser.state.tests
-
-[ "hello" ]
-[ "hello" [ take-rest ] state-parse ] unit-test
-
-[ "hi" " how are you?" ]
-[
- "hi how are you?"
- [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
-] unit-test
-
-[ "foo" ";bar" ]
-[
- "foo;bar" [
- [ CHAR: ; take-until-object ] [ take-rest ] bi
- ] state-parse
-] unit-test
-
-[ "foo " " bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence ] [ take-rest ] bi
- ] state-parse
-] unit-test
-
-[ 6 ]
-[
- " foo " [ skip-whitespace n>> ] state-parse
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 } <state-parser> [ current 3 = ] take-until ] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
-
-[ "ab" ]
-[ "abcd" <state-parser> "ab" take-sequence ] unit-test
-
-[ f ]
-[ "abcd" <state-parser> "lol" take-sequence ] unit-test
-
-[ "ab" ]
-[
- "abcd" <state-parser>
- [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
-] unit-test
-
-[ "" ]
-[ "abcd" <state-parser> "" take-sequence ] unit-test
-
-[ "cd" ]
-[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
-
-[ f ]
-[
- "\"abc\" asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
-] unit-test
-
-[ "abc\\\"def" ]
-[
- "\"abc\\\"def\" asdf" <state-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "asdf" ]
-[
- "\"abc\" asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ skip-whitespace "asdf" take-sequence ] bi
-] unit-test
-
-[ f ]
-[
- "\"abc asdf" <state-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "\"abc" ]
-[
- "\"abc asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ "\"abc" take-sequence ] bi
-] unit-test
-
-[ "c" ]
-[ "c" <state-parser> take-token ] unit-test
-
-[ f ]
-[ "" <state-parser> take-token ] unit-test
-
-[ "abcd e \\\"f g" ]
-[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
-
-[ "" ]
-[ "" <state-parser> take-rest ] unit-test
-
-[ "" ]
-[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
-
-[ f ]
-[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
deleted file mode 100644
index 2bcd08be5f..0000000000
--- a/extra/html/parser/state/state.factor
+++ /dev/null
@@ -1,127 +0,0 @@
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals combinators.short-circuit
-make combinators io splitting ;
-
-IN: html.parser.state
-
-TUPLE: state-parser sequence n ;
-
-: <state-parser> ( sequence -- state-parser )
- state-parser new
- swap >>sequence
- 0 >>n ;
-
-: offset ( state-parser offset -- char/f )
- swap
- [ n>> + ] [ sequence>> ?nth ] bi ; inline
-
-: current ( state-parser -- char/f ) 0 offset ; inline
-
-: previous ( state-parser -- char/f ) -1 offset ; inline
-
-: peek-next ( state-parser -- char/f ) 1 offset ; inline
-
-: advance ( state-parser -- state-parser )
- [ 1 + ] change-n ; inline
-
-: advance* ( state-parser -- )
- advance drop ; inline
-
-: get+increment ( state-parser -- char/f )
- [ current ] [ advance drop ] bi ; inline
-
-:: skip-until ( state-parser quot: ( obj -- ? ) -- )
- state-parser current [
- state-parser quot call [ state-parser advance quot skip-until ] unless
- ] when ; inline recursive
-
-: state-parse-end? ( state-parser -- ? ) current not ;
-
-: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
- over state-parse-end? [
- 2drop f
- ] [
- [ drop n>> ]
- [ skip-until ]
- [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
- ] if ; inline
-
-: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
- [ not ] compose take-until ; inline
-
-: <safe-slice> ( from to seq -- slice/f )
- 3dup {
- [ 2drop 0 < ]
- [ [ drop ] 2dip length > ]
- [ drop > ]
- } 3|| [ 3drop f ] [ slice boa ] if ; inline
-
-:: take-sequence ( state-parser sequence -- obj/f )
- state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
- <safe-slice> sequence sequence= [
- sequence
- state-parser [ sequence length + ] change-n drop
- ] [
- f
- ] if ;
-
-:: take-until-sequence ( state-parser sequence -- sequence' )
- sequence length <growing-circular> :> growing
- state-parser
- [
- current growing push-growing-circular
- sequence growing sequence=
- ] take-until :> found
- found dup length
- growing length 1- - head
- state-parser advance drop ;
-
-: skip-whitespace ( state-parser -- state-parser )
- [ [ current blank? not ] take-until drop ] keep ;
-
-: take-rest-slice ( state-parser -- sequence/f )
- [ sequence>> ] [ n>> ] bi
- 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
-
-: take-rest ( state-parser -- sequence )
- [ take-rest-slice ] [ sequence>> like ] bi ;
-
-: take-until-object ( state-parser obj -- sequence )
- '[ current _ = ] take-until ;
-
-: state-parse ( sequence quot -- )
- [ <state-parser> ] dip call ; inline
-
-:: take-quoted-string ( state-parser escape-char quote-char -- string )
- state-parser n>> :> start-n
- state-parser advance
- [
- {
- [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
- [ current quote-char = not ]
- } 1||
- ] take-while :> string
- state-parser current quote-char = [
- state-parser advance* string
- ] [
- start-n state-parser (>>n) f
- ] if ;
-
-: (take-token) ( state-parser -- string )
- skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
-
-:: take-token* ( state-parser escape-char quote-char -- string/f )
- state-parser skip-whitespace
- dup current {
- { quote-char [ escape-char quote-char take-quoted-string ] }
- { f [ drop f ] }
- [ drop (take-token) ]
- } case ;
-
-: take-token ( state-parser -- string/f )
- CHAR: \ CHAR: " take-token* ;
-
-: write-full ( state-parser -- ) sequence>> write ;
-: write-rest ( state-parser -- ) take-rest write ;
diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor
index 7abd2fcdf7..afd63daf6b 100644
--- a/extra/html/parser/utils/utils.factor
+++ b/extra/html/parser/utils/utils.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math namespaces prettyprint
-quotations sequences splitting html.parser.state strings
-combinators.short-circuit quoting ;
+quotations sequences splitting strings quoting
+combinators.short-circuit ;
IN: html.parser.utils
: trim1 ( seq ch -- newseq )
diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor
new file mode 100644
index 0000000000..915d119abe
--- /dev/null
+++ b/extra/sequence-parser/sequence-parser-tests.factor
@@ -0,0 +1,104 @@
+USING: tools.test sequence-parser ascii kernel accessors ;
+IN: sequence-parser.tests
+
+[ "hello" ]
+[ "hello" [ take-rest ] parse-sequence ] unit-test
+
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace n>> ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ "ab" ]
+[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+ "abcd" <sequence-parser>
+ [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <sequence-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+[ f ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+ "\"abc\\\"def\" asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+ "\"abc asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <sequence-parser> take-token ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "" ]
+[ "" <sequence-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor
new file mode 100644
index 0000000000..ad49982d88
--- /dev/null
+++ b/extra/sequence-parser/sequence-parser.factor
@@ -0,0 +1,126 @@
+! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces math kernel sequences accessors fry circular
+unicode.case unicode.categories locals combinators.short-circuit
+make combinators io splitting ;
+IN: sequence-parser
+
+TUPLE: sequence-parser sequence n ;
+
+: <sequence-parser> ( sequence -- sequence-parser )
+ sequence-parser new
+ swap >>sequence
+ 0 >>n ;
+
+: offset ( sequence-parser offset -- char/f )
+ swap
+ [ n>> + ] [ sequence>> ?nth ] bi ; inline
+
+: current ( sequence-parser -- char/f ) 0 offset ; inline
+
+: previous ( sequence-parser -- char/f ) -1 offset ; inline
+
+: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
+
+: advance ( sequence-parser -- sequence-parser )
+ [ 1 + ] change-n ; inline
+
+: advance* ( sequence-parser -- )
+ advance drop ; inline
+
+: get+increment ( sequence-parser -- char/f )
+ [ current ] [ advance drop ] bi ; inline
+
+:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+ sequence-parser current [
+ sequence-parser quot call [ sequence-parser advance quot skip-until ] unless
+ ] when ; inline recursive
+
+: sequence-parse-end? ( sequence-parser -- ? ) current not ;
+
+: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ over sequence-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+ ] if ; inline
+
+: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ [ not ] compose take-until ; inline
+
+: <safe-slice> ( from to seq -- slice/f )
+ 3dup {
+ [ 2drop 0 < ]
+ [ [ drop ] 2dip length > ]
+ [ drop > ]
+ } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
+:: take-sequence ( sequence-parser sequence -- obj/f )
+ sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+ <safe-slice> sequence sequence= [
+ sequence
+ sequence-parser [ sequence length + ] change-n drop
+ ] [
+ f
+ ] if ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence' )
+ sequence length <growing-circular> :> growing
+ sequence-parser
+ [
+ current growing push-growing-circular
+ sequence growing sequence=
+ ] take-until :> found
+ found dup length
+ growing length 1- - head
+ sequence-parser advance drop ;
+
+: skip-whitespace ( sequence-parser -- sequence-parser )
+ [ [ current blank? not ] take-until drop ] keep ;
+
+: take-rest-slice ( sequence-parser -- sequence/f )
+ [ sequence>> ] [ n>> ] bi
+ 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
+: take-rest ( sequence-parser -- sequence )
+ [ take-rest-slice ] [ sequence>> like ] bi ;
+
+: take-until-object ( sequence-parser obj -- sequence )
+ '[ current _ = ] take-until ;
+
+: parse-sequence ( sequence quot -- )
+ [ <sequence-parser> ] dip call ; inline
+
+:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
+ sequence-parser n>> :> start-n
+ sequence-parser advance
+ [
+ {
+ [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
+ [ current quote-char = not ]
+ } 1||
+ ] take-while :> string
+ sequence-parser current quote-char = [
+ sequence-parser advance* string
+ ] [
+ start-n sequence-parser (>>n) f
+ ] if ;
+
+: (take-token) ( sequence-parser -- string )
+ skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+
+:: take-token* ( sequence-parser escape-char quote-char -- string/f )
+ sequence-parser skip-whitespace
+ dup current {
+ { quote-char [ escape-char quote-char take-quoted-string ] }
+ { f [ drop f ] }
+ [ drop (take-token) ]
+ } case ;
+
+: take-token ( sequence-parser -- string/f )
+ CHAR: \ CHAR: " take-token* ;
+
+: write-full ( sequence-parser -- ) sequence>> write ;
+: write-rest ( sequence-parser -- ) take-rest write ;
From 47369e927c740bc6481b6da24b611965f7647b69 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 9 Apr 2009 15:29:38 -0500
Subject: [PATCH 15/33] add a combinator to spider
---
extra/spider/unique-deque/unique-deque.factor | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor
index ad46abdad3..b26797f8d5 100644
--- a/extra/spider/unique-deque/unique-deque.factor
+++ b/extra/spider/unique-deque/unique-deque.factor
@@ -29,3 +29,9 @@ TUPLE: unique-deque assoc deque ;
: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+
+: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
+ pick deque-empty? [ 3drop ] [
+ [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+ [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
+ ] if ; inline recursive
From d44c08bf68a7d31eab30e7981fdec483a280f3f6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 9 Apr 2009 18:23:05 -0500
Subject: [PATCH 16/33] write synchsafe numbers to sequences
---
extra/id3/id3-tests.factor | 6 +++++-
extra/id3/id3.factor | 12 ++++++++----
2 files changed, 13 insertions(+), 5 deletions(-)
diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor
index a8f35e582c..9bb7558077 100644
--- a/extra/id3/id3-tests.factor
+++ b/extra/id3/id3-tests.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test id3 combinators ;
+USING: tools.test id3 combinators grouping id3.private
+sequences math ;
IN: id3.tests
: id3-params ( id3 -- title artist album year comment genre )
@@ -40,3 +41,6 @@ IN: id3.tests
"Big Band"
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
+
+[ t ]
+[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor
index 8a235d305d..a742a1f08d 100644
--- a/extra/id3/id3.factor
+++ b/extra/id3/id3.factor
@@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search literals ;
+io.directories.search literals math.functions ;
IN: id3
<PRIVATE
@@ -100,9 +100,13 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
} cleave
] output>array sift ;
-: >28bitword ( seq -- int )
+: seq>synchsafe ( seq -- n )
0 [ [ 7 shift ] dip bitor ] reduce ; inline
+: synchsafe>seq ( n -- seq )
+ dup 1+ log2 1+ 7 / ceiling
+ [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ; inline
+
: filter-text-data ( data -- filtered )
[ printable? ] filter ; inline
@@ -121,7 +125,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
[ <frame> ] dip
{
[ 4 head-slice decode-text >>tag ]
- [ [ 4 8 ] dip subseq >28bitword >>size ]
+ [ [ 4 8 ] dip subseq seq>synchsafe >>size ]
[ [ 8 10 ] dip subseq >byte-array >>flags ]
[ read-frame-data decode-text >>data ]
} cleave ; inline
@@ -144,7 +148,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
{
[ [ 3 5 ] dip <slice> >array >>version ]
[ [ 5 ] dip nth >>flags ]
- [ [ 6 10 ] dip <slice> >28bitword >>size ]
+ [ [ 6 10 ] dip <slice> seq>synchsafe >>size ]
} cleave ; inline
: merge-frames ( id3 assoc -- id3 )
From a6989d3087c849d8b8d9488b2710937ce17d48c7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 9 Apr 2009 19:50:25 -0500
Subject: [PATCH 17/33] fix bug in base64 -- would fail with bitor trying to OR
f with an integer
---
basis/base64/base64-tests.factor | 3 +++
basis/base64/base64.factor | 6 +++---
2 files changed, 6 insertions(+), 3 deletions(-)
diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor
index ddefff35bb..572d8a5227 100644
--- a/basis/base64/base64-tests.factor
+++ b/basis/base64/base64-tests.factor
@@ -23,5 +23,8 @@ IN: base64.tests
ascii encode >base64-lines >string
] unit-test
+[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
+[ malformed-base64? ] must-fail-with
+
\ >base64 must-infer
\ base64> must-infer
diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor
index c51d871bb5..111fe49f95 100644
--- a/basis/base64/base64.factor
+++ b/basis/base64/base64.factor
@@ -18,6 +18,8 @@ IN: base64
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
nth ; inline
+ERROR: malformed-base64 ;
+
: base64>ch ( ch -- ch )
{
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
@@ -25,7 +27,7 @@ IN: base64
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
- } nth ; inline
+ } nth [ malformed-base64 ] unless* ; inline
SYMBOL: column
@@ -48,8 +50,6 @@ SYMBOL: column
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
-ERROR: malformed-base64 ;
-
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*
From a761d570198db662a0f0705a920d44d9c79dc8ba Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 9 Apr 2009 21:03:18 -0500
Subject: [PATCH 18/33] improve sequence-parser
---
.../sequence-parser-tests.factor | 44 +++++++++++++++++--
extra/sequence-parser/sequence-parser.factor | 39 +++++++++++++---
2 files changed, 73 insertions(+), 10 deletions(-)
diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor
index 915d119abe..715beae5da 100644
--- a/extra/sequence-parser/sequence-parser-tests.factor
+++ b/extra/sequence-parser/sequence-parser-tests.factor
@@ -17,13 +17,39 @@ IN: sequence-parser.tests
] parse-sequence
] unit-test
-[ "foo " " bar" ]
+[ "foo " "and bar" ]
[
"foo and bar" [
[ "and" take-until-sequence ] [ take-rest ] bi
] parse-sequence
] unit-test
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ]
+ [ "and" take-sequence drop ]
+ [ take-rest ] tri
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence* ]
+ [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ f "aaaa" ]
+[
+ "aaaa" <sequence-parser>
+ [ "b" take-until-sequence ] [ take-rest ] bi
+] unit-test
+
[ 6 ]
[
" foo " [ skip-whitespace n>> ] parse-sequence
@@ -32,9 +58,6 @@ IN: sequence-parser.tests
[ { 1 2 } ]
[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
-[ { 1 2 } ]
-[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
-
[ "ab" ]
[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
@@ -102,3 +125,16 @@ IN: sequence-parser.tests
[ f ]
[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
+
+[ 1234 ]
+[ "1234f" <sequence-parser> take-integer ] unit-test
+
+[ "yes" ]
+[
+ "yes1234f" <sequence-parser>
+ [ take-integer drop ] [ "yes" take-sequence ] bi
+] unit-test
+
+[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor
index ad49982d88..22f133bf70 100644
--- a/extra/sequence-parser/sequence-parser.factor
+++ b/extra/sequence-parser/sequence-parser.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math kernel sequences accessors fry circular
unicode.case unicode.categories locals combinators.short-circuit
-make combinators io splitting ;
+make combinators io splitting math.parser ;
IN: sequence-parser
TUPLE: sequence-parser sequence n ;
@@ -66,17 +66,33 @@ TUPLE: sequence-parser sequence n ;
f
] if ;
-:: take-until-sequence ( sequence-parser sequence -- sequence' )
+: take-sequence* ( sequence-parser sequence -- )
+ take-sequence drop ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
+ sequence-parser n>> :> saved
sequence length <growing-circular> :> growing
sequence-parser
[
current growing push-growing-circular
sequence growing sequence=
] take-until :> found
- found dup length
- growing length 1- - head
- sequence-parser advance drop ;
-
+ growing sequence sequence= [
+ found dup length
+ growing length 1- - head
+ sequence-parser [ growing length - 1 + ] change-n drop
+ ! sequence-parser advance drop
+ ] [
+ saved sequence-parser (>>n)
+ f
+ ] if ;
+
+:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
+ sequence-parser sequence take-until-sequence :> out
+ out [
+ sequence-parser [ sequence length + ] change-n drop
+ ] when out ;
+
: skip-whitespace ( sequence-parser -- sequence-parser )
[ [ current blank? not ] take-until drop ] keep ;
@@ -122,5 +138,16 @@ TUPLE: sequence-parser sequence n ;
: take-token ( sequence-parser -- string/f )
CHAR: \ CHAR: " take-token* ;
+: take-integer ( sequence-parser -- n/f )
+ [ current digit? ] take-while string>number ;
+
+:: take-n ( sequence-parser n -- seq/f )
+ n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+ f
+ ] [
+ sequence-parser n>> dup n + sequence-parser sequence>> subseq
+ sequence-parser [ n + ] change-n drop
+ ] if ;
+
: write-full ( sequence-parser -- ) sequence>> write ;
: write-rest ( sequence-parser -- ) take-rest write ;
From 2179b4bca13f794be09b7ab1345106d01dc44560 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 9 Apr 2009 21:03:42 -0500
Subject: [PATCH 19/33] minor cleanup
---
basis/tools/hexdump/hexdump.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor
index 63b55729fb..666e051088 100644
--- a/basis/tools/hexdump/hexdump.factor
+++ b/basis/tools/hexdump/hexdump.factor
@@ -16,10 +16,11 @@ IN: tools.hexdump
16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
: >hex-digit ( digit -- str )
- >hex 2 CHAR: 0 pad-head " " append ;
+ >hex 2 CHAR: 0 pad-head ;
: >hex-digits ( bytes -- str )
- [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
+ [ >hex-digit " " append ] { } map-as concat
+ 48 CHAR: \s pad-tail ;
: >ascii ( bytes -- str )
[ [ printable? ] keep CHAR: . ? ] "" map-as ;
From 732065d7759d5b5368948808a48d4185540c91c7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 9 Apr 2009 21:32:57 -0500
Subject: [PATCH 20/33] more work on sequence-parser
---
.../sequence-parser-tests.factor | 12 ++++++++++++
extra/sequence-parser/sequence-parser.factor | 18 +++++++++++++++++-
2 files changed, 29 insertions(+), 1 deletion(-)
diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor
index 715beae5da..f6339b7127 100644
--- a/extra/sequence-parser/sequence-parser-tests.factor
+++ b/extra/sequence-parser/sequence-parser-tests.factor
@@ -138,3 +138,15 @@ IN: sequence-parser.tests
[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
+
+[ "asdfasdf" ] [
+ "/*asdfasdf*/" <sequence-parser> take-c-comment
+] unit-test
+
+[ "k" ] [
+ "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "/*asdfasdf" ] [
+ "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor
index 22f133bf70..d5adc56800 100644
--- a/extra/sequence-parser/sequence-parser.factor
+++ b/extra/sequence-parser/sequence-parser.factor
@@ -12,6 +12,12 @@ TUPLE: sequence-parser sequence n ;
swap >>sequence
0 >>n ;
+:: with-sequence-parser ( sequence-parser quot -- seq/f )
+ sequence-parser n>> :> n
+ sequence-parser quot call [
+ n sequence-parser (>>n) f
+ ] unless* ; inline
+
: offset ( sequence-parser offset -- char/f )
swap
[ n>> + ] [ sequence>> ?nth ] bi ; inline
@@ -33,7 +39,8 @@ TUPLE: sequence-parser sequence n ;
:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
sequence-parser current [
- sequence-parser quot call [ sequence-parser advance quot skip-until ] unless
+ sequence-parser quot call
+ [ sequence-parser advance quot skip-until ] unless
] when ; inline recursive
: sequence-parse-end? ( sequence-parser -- ? ) current not ;
@@ -149,5 +156,14 @@ TUPLE: sequence-parser sequence n ;
sequence-parser [ n + ] change-n drop
] if ;
+: take-c-comment ( sequence-parser -- seq/f )
+ [
+ dup "/*" take-sequence [
+ "*/" take-until-sequence*
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
: write-full ( sequence-parser -- ) sequence>> write ;
: write-rest ( sequence-parser -- ) take-rest write ;
From a0ba66080d86a9aa624bdabd8c617d9337d2e9d4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Apr 2009 03:52:53 -0500
Subject: [PATCH 21/33] Documentation updates suggested by dmpk2k
---
basis/help/handbook/handbook.factor | 2 ++
core/classes/tuple/tuple-docs.factor | 10 +++++-----
2 files changed, 7 insertions(+), 5 deletions(-)
diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
index b2a0e56c0a..0845264d61 100644
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -49,6 +49,7 @@ $nl
{ "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
{ "boolean" { { $link t } " or " { $link f } } }
{ "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
+ { "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } }
{ "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } }
{ "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } }
{ "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
@@ -56,6 +57,7 @@ $nl
{ "object" { "any datum which can be identified" } }
{ "ordering specifier" { "see " { $link "order-specifiers" } } }
{ "pathname string" { "an OS-specific pathname which identifies a file" } }
+ { "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } }
{ "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
{ "slot" { "a component of an object which can store a value" } }
{ "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 32cab65904..d76faddf15 100644
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -92,7 +92,7 @@ ARTICLE: "tuple-constructors" "Tuple constructors"
$nl
"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "."
$nl
-"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
+"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construct a different class, without breaking callers."
$nl
"Examples of constructors:"
{ $code
@@ -220,13 +220,13 @@ ARTICLE: "tuple-examples" "Tuple examples"
" <employee> \"project manager\" >>position ;" }
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
- ": <employee> ( name position -- person )"
+ ": <employee> ( name position -- employee )"
" 40000 employee boa ;"
}
"Now we can define more specific constructors:"
{ $code
- ": <manager> ( name -- person )"
- " \"manager\" <person> ;" }
+ ": <manager> ( name -- employee )"
+ " \"manager\" <employee> ;" }
"An example using reader words:"
{ $code
"TUPLE: check to amount number ;"
@@ -256,7 +256,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
": next-position ( role -- newrole )"
" positions [ index 1+ ] keep nth ;"
""
- ": promote ( person -- person )"
+ ": promote ( employee -- employee )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
}
From b11e0f60372ae13f7eea4f904d4781025fe644ca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Apr 2009 04:01:59 -0500
Subject: [PATCH 22/33] assoc>query should not insert = if value is f. Reported
by Chris Double
---
basis/urls/encoding/encoding-tests.factor | 4 ++++
basis/urls/encoding/encoding.factor | 16 +++++++++++-----
basis/urls/urls-tests.factor | 9 +++++++++
3 files changed, 24 insertions(+), 5 deletions(-)
diff --git a/basis/urls/encoding/encoding-tests.factor b/basis/urls/encoding/encoding-tests.factor
index 87b1812ef8..78e31a764d 100644
--- a/basis/urls/encoding/encoding-tests.factor
+++ b/basis/urls/encoding/encoding-tests.factor
@@ -26,3 +26,7 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
+
+[ "a" ] [ { { "a" f } } assoc>query ] unit-test
+
+[ H{ { "a" f } } ] [ "a" query>assoc ] unit-test
\ No newline at end of file
diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor
index 7fed4b5f58..15b71ac0db 100644
--- a/basis/urls/encoding/encoding.factor
+++ b/basis/urls/encoding/encoding.factor
@@ -72,6 +72,15 @@ PRIVATE>
] when*
] 2keep set-at ;
+: assoc-strings ( assoc -- assoc' )
+ [
+ {
+ { [ dup not ] [ ] }
+ { [ dup array? ] [ [ present ] map ] }
+ [ present 1array ]
+ } cond
+ ] assoc-map ;
+
PRIVATE>
: query>assoc ( query -- assoc )
@@ -86,11 +95,8 @@ PRIVATE>
: assoc>query ( assoc -- str )
[
- dup array? [ [ present ] map ] [ present 1array ] if
- ] assoc-map
- [
- [
+ assoc-strings [
[ url-encode ] dip
- [ url-encode "=" glue , ] with each
+ [ [ url-encode "=" glue , ] with each ] [ , ] if*
] assoc-each
] { } make "&" join ;
diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor
index f45ad6449e..f2ecd6ec69 100644
--- a/basis/urls/urls-tests.factor
+++ b/basis/urls/urls-tests.factor
@@ -80,6 +80,15 @@ CONSTANT: urls
}
"ftp://slava:secret@ftp.kernel.org/"
}
+ {
+ T{ url
+ { protocol "http" }
+ { host "foo.com" }
+ { path "/" }
+ { query H{ { "a" f } } }
+ }
+ "http://foo.com/?a"
+ }
}
urls [
From 2b26da1ad23f73c47f2182c846337677386d5674 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Apr 2009 04:03:06 -0500
Subject: [PATCH 23/33] Move images.normalization to extra since its not used
for anything anymore
---
{basis => extra}/images/normalization/authors.txt | 0
{basis => extra}/images/normalization/normalization.factor | 0
2 files changed, 0 insertions(+), 0 deletions(-)
rename {basis => extra}/images/normalization/authors.txt (100%)
rename {basis => extra}/images/normalization/normalization.factor (100%)
diff --git a/basis/images/normalization/authors.txt b/extra/images/normalization/authors.txt
similarity index 100%
rename from basis/images/normalization/authors.txt
rename to extra/images/normalization/authors.txt
diff --git a/basis/images/normalization/normalization.factor b/extra/images/normalization/normalization.factor
similarity index 100%
rename from basis/images/normalization/normalization.factor
rename to extra/images/normalization/normalization.factor
From 713ab023379ab4b4cb229c97e10cd1d38e2cf73d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Apr 2009 06:18:29 -0500
Subject: [PATCH 24/33] Don't use GL_ARB_texture_non_power_of_two on ATI
hardware to fix bug reported by Andy Turner and Caesar Hu
---
basis/opengl/capabilities/capabilities.factor | 2 ++
basis/opengl/textures/textures.factor | 16 +++++++++++++---
basis/ui/gadgets/worlds/worlds.factor | 10 +++-------
3 files changed, 18 insertions(+), 10 deletions(-)
diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor
index 09d49b33c2..ad04ce7fa5 100755
--- a/basis/opengl/capabilities/capabilities.factor
+++ b/basis/opengl/capabilities/capabilities.factor
@@ -32,6 +32,8 @@ IN: opengl.capabilities
(gl-version) drop ;
: gl-vendor-version ( -- version )
(gl-version) nip ;
+: gl-vendor ( -- name )
+ GL_VENDOR glGetString ;
: has-gl-version? ( version -- ? )
gl-version version-before? ;
: (make-gl-version-error) ( required-version -- )
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index a565a14597..76e0c473b9 100755
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -1,13 +1,23 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache colors.constants destructors fry kernel
-opengl opengl.gl combinators images images.tesselation grouping
-specialized-arrays.float sequences math math.vectors
-math.matrices generalizations fry arrays namespaces ;
+opengl opengl.gl opengl.capabilities combinators images
+images.tesselation grouping specialized-arrays.float sequences math
+math.vectors math.matrices generalizations fry arrays namespaces
+system ;
IN: opengl.textures
SYMBOL: non-power-of-2-textures?
+: check-extensions ( -- )
+ #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
+ #! See thread 'Linux font display problem' April 2009 on Factor-talk
+ gl-vendor "ATI Technologies Inc." = not os macosx? or [
+ "2.0" { "GL_ARB_texture_non_power_of_two" }
+ has-gl-version-or-extensions?
+ non-power-of-2-textures? set
+ ] when ;
+
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index f671add531..a186de7670 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
-namespaces opengl opengl.capabilities opengl.textures sequences io
-combinators combinators.short-circuit fry math.vectors math.rectangles
-cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
+namespaces opengl opengl.textures sequences io combinators
+combinators.short-circuit fry math.vectors math.rectangles cache
+ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
ui.commands ;
IN: ui.gadgets.worlds
@@ -77,10 +77,6 @@ SYMBOL: flush-layout-cache-hook
flush-layout-cache-hook [ [ ] ] initialize
-: check-extensions ( -- )
- "2.0" { "GL_ARB_texture_non_power_of_two" } has-gl-version-or-extensions?
- non-power-of-2-textures? set ;
-
: (draw-world) ( world -- )
dup handle>> [
check-extensions
From 370e90f57bc535a950d28091b41ff5197ecf7038 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Apr 2009 06:19:46 -0500
Subject: [PATCH 25/33] Fix odd race condition in ui.backend.cocoa
---
basis/ui/backend/cocoa/cocoa.factor | 2 +-
basis/ui/backend/cocoa/views/views.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor
index fc392c595d..1bbf46c69e 100755
--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/basis/ui/backend/cocoa/cocoa.factor
@@ -70,8 +70,8 @@ M:: cocoa-ui-backend (open-window) ( world -- )
world dim>> <FactorView> :> view
view world world>NSRect <ViewWindow> :> window
view -> release
- window world window-loc>> auto-position
world view register-window
+ window world window-loc>> auto-position
world window save-position
window install-window-delegate
view window <window-handle> world (>>handle)
diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor
index b59848260d..602c9bec73 100644
--- a/basis/ui/backend/cocoa/views/views.factor
+++ b/basis/ui/backend/cocoa/views/views.factor
@@ -336,7 +336,7 @@ CLASS: {
! Initialization
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [ 2drop dup view-dim swap window (>>dim) yield ]
+ [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
}
{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
From e2c858da3481213f7fd74ddfc9ed393bd47f608d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Apr 2009 06:20:23 -0500
Subject: [PATCH 26/33] Add better error check for 'window' word
---
basis/ui/ui.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index dff7726d08..1de3912f28 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -12,7 +12,10 @@ IN: ui
! Assoc mapping aliens to gadgets
SYMBOL: windows
-: window ( handle -- world ) windows get-global at ;
+ERROR: no-window handle ;
+
+: window ( handle -- world )
+ windows get-global ?at [ no-window ] unless ;
: window-focus ( handle -- gadget ) window world-focus ;
From 509869ca70e08504045cf1cc0d0e2558d00eaa6a Mon Sep 17 00:00:00 2001
From: slava <slava@linux-vm.(none)>
Date: Fri, 10 Apr 2009 13:29:07 -0400
Subject: [PATCH 27/33] X11 UI: Fix resize flicker, exception when closing
window, unsuccessful attempt at fixing raise-window
---
basis/ui/backend/x11/x11.factor | 12 ++++++++++--
basis/ui/ui.factor | 7 ++-----
basis/x11/windows/windows.factor | 6 ++----
3 files changed, 14 insertions(+), 11 deletions(-)
diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor
index 422efbd188..5a2a8974e7 100755
--- a/basis/ui/backend/x11/x11.factor
+++ b/basis/ui/backend/x11/x11.factor
@@ -224,6 +224,10 @@ M: x-clipboard paste-clipboard
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
utf8 encode dup length XChangeProperty drop ;
+: set-class ( dpy window -- )
+ XA_WM_CLASS XA_STRING 8 PropModeReplace "Factor"
+ utf8 encode dup length XChangeProperty drop ;
+
M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
@@ -242,11 +246,15 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
- handle>> window>> dup set-closable map-window ;
+ handle>> window>>
+ [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
M: x11-ui-backend raise-window* ( world -- )
handle>> [
- dpy get swap window>> XRaiseWindow drop
+ dpy get swap window>>
+ [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
+ [ XRaiseWindow drop ]
+ 2bi
] when* ;
M: x11-handle select-gl-context ( handle -- )
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 1de3912f28..8be486cb1a 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -12,10 +12,7 @@ IN: ui
! Assoc mapping aliens to gadgets
SYMBOL: windows
-ERROR: no-window handle ;
-
-: window ( handle -- world )
- windows get-global ?at [ no-window ] unless ;
+: window ( handle -- world ) windows get-global at ;
: window-focus ( handle -- gadget ) window world-focus ;
@@ -199,4 +196,4 @@ M: object close-window
: with-ui ( quot -- )
ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
-HOOK: beep ui-backend ( -- )
\ No newline at end of file
+HOOK: beep ui-backend ( -- )
diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor
index 9619ae0bee..8085907bef 100644
--- a/basis/x11/windows/windows.factor
+++ b/basis/x11/windows/windows.factor
@@ -6,10 +6,10 @@ arrays fry ;
IN: x11.windows
: create-window-mask ( -- n )
- { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
+ { CWColormap CWEventMask } flags ;
: create-colormap ( visinfo -- colormap )
- dpy get root get rot XVisualInfo-visual AllocNone
+ [ dpy get root get ] dip XVisualInfo-visual AllocNone
XCreateColormap ;
: event-mask ( -- n )
@@ -29,8 +29,6 @@ IN: x11.windows
: window-attributes ( visinfo -- attributes )
"XSetWindowAttributes" <c-object>
- 0 over set-XSetWindowAttributes-background_pixel
- 0 over set-XSetWindowAttributes-border_pixel
[ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
event-mask over set-XSetWindowAttributes-event_mask ;
From a10d490fe2e318de5d55038983474012933abdfc Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 10 Apr 2009 17:50:05 -0500
Subject: [PATCH 28/33] more parsing work
---
extra/c/preprocessor/preprocessor.factor | 68 +++++++++++--------
.../sequence-parser-tests.factor | 41 ++++++++++-
extra/sequence-parser/sequence-parser.factor | 64 ++++++++++++++++-
3 files changed, 140 insertions(+), 33 deletions(-)
diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor
index e5029ca683..f787befc31 100644
--- a/extra/c/preprocessor/preprocessor.factor
+++ b/extra/c/preprocessor/preprocessor.factor
@@ -41,7 +41,7 @@ ifs elifs elses ;
DEFER: preprocess-file
-ERROR: unknown-c-preprocessor state-parser name ;
+ERROR: unknown-c-preprocessor sequence-parser name ;
ERROR: bad-include-line line ;
@@ -69,8 +69,16 @@ ERROR: header-file-missing path ;
drop
] if ;
-: handle-include ( preprocessor-state state-parser -- )
- skip-whitespace advance dup previous {
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: handle-include ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments advance dup previous {
{ CHAR: < [ CHAR: > take-until-object read-standard-include ] }
{ CHAR: " [ CHAR: " take-until-object read-local-include ] }
[ bad-include-line ]
@@ -81,58 +89,58 @@ ERROR: header-file-missing path ;
: readlns ( -- string ) [ (readlns) ] { } make concat ;
-: take-define-identifier ( state-parser -- string )
- skip-whitespace
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
-: handle-define ( preprocessor-state state-parser -- )
+: handle-define ( preprocessor-state sequence-parser -- )
[ take-define-identifier ]
- [ skip-whitespace take-rest ] bi
+ [ skip-whitespace/comments take-rest ] bi
"\\" ?tail [ readlns append ] when
spin symbol-table>> set-at ;
-: handle-undef ( preprocessor-state state-parser -- )
+: handle-undef ( preprocessor-state sequence-parser -- )
take-token swap symbol-table>> delete-at ;
-: handle-ifdef ( preprocessor-state state-parser -- )
+: handle-ifdef ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ drop ] [ t >>processing-disabled? drop ] if ;
-: handle-ifndef ( preprocessor-state state-parser -- )
+: handle-ifndef ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ t >>processing-disabled? drop ]
[ drop ] if ;
-: handle-endif ( preprocessor-state state-parser -- )
+: handle-endif ( preprocessor-state sequence-parser -- )
drop [ 1 - ] change-ifdef-nesting drop ;
-: handle-if ( preprocessor-state state-parser -- )
+: handle-if ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
- skip-whitespace take-rest swap ifs>> push ;
+ skip-whitespace/comments take-rest swap ifs>> push ;
-: handle-elif ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap elifs>> push ;
+: handle-elif ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap elifs>> push ;
-: handle-else ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap elses>> push ;
+: handle-else ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap elses>> push ;
-: handle-pragma ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap pragmas>> push ;
+: handle-pragma ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap pragmas>> push ;
-: handle-include-next ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap include-nexts>> push ;
+: handle-include-next ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap include-nexts>> push ;
-: handle-error ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap errors>> push ;
+: handle-error ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap errors>> push ;
! nip take-rest throw ;
-: handle-warning ( preprocessor-state state-parser -- )
- skip-whitespace
+: handle-warning ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments
take-rest swap warnings>> push ;
-: parse-directive ( preprocessor-state state-parser string -- )
+: parse-directive ( preprocessor-state sequence-parser string -- )
{
{ "warning" [ handle-warning ] }
{ "error" [ handle-error ] }
@@ -150,7 +158,7 @@ ERROR: header-file-missing path ;
[ unknown-c-preprocessor ]
} case ;
-: parse-directive-line ( preprocessor-state state-parser -- )
+: parse-directive-line ( preprocessor-state sequence-parser -- )
advance dup take-token
pick processing-disabled?>> [
"endif" = [
@@ -162,14 +170,14 @@ ERROR: header-file-missing path ;
parse-directive
] if ;
-: preprocess-line ( preprocessor-state state-parser -- )
- skip-whitespace dup current CHAR: # =
+: preprocess-line ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments dup current CHAR: # =
[ parse-directive-line ]
[ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
: preprocess-lines ( preprocessor-state -- )
readln
- [ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+ [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
[ drop ] if* ;
ERROR: include-nested-too-deeply ;
diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor
index f6339b7127..3b2fcad5eb 100644
--- a/extra/sequence-parser/sequence-parser-tests.factor
+++ b/extra/sequence-parser/sequence-parser-tests.factor
@@ -126,7 +126,7 @@ IN: sequence-parser.tests
[ f ]
[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
-[ 1234 ]
+[ "1234" ]
[ "1234f" <sequence-parser> take-integer ] unit-test
[ "yes" ]
@@ -147,6 +147,45 @@ IN: sequence-parser.tests
"/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
] unit-test
+[ "omg" ] [
+ "//asdfasdf\nomg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "omg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
[ "/*asdfasdf" ] [
"/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
] unit-test
+
+[ "asdf" "eoieoei" ] [
+ "//asdf\neoieoei" <sequence-parser>
+ [ take-c++-comment ] [ take-rest ] bi
+] unit-test
+
+[ f "33asdf" ]
+[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
+
+[ "asdf" ]
+[ "asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf" ]
+[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf400" ]
+[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
+
+[ "123" ]
+[ "123jjj" <sequence-parser> take-c-integer ] unit-test
+
+[ "123uLL" ]
+[ "123uLL" <sequence-parser> take-c-integer ] unit-test
+
+[ "123ull" ]
+[ "123ull" <sequence-parser> take-c-integer ] unit-test
+
+[ "123u" ]
+[ "123u" <sequence-parser> take-c-integer ] unit-test
diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor
index d5adc56800..4f57a7ccae 100644
--- a/extra/sequence-parser/sequence-parser.factor
+++ b/extra/sequence-parser/sequence-parser.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math kernel sequences accessors fry circular
unicode.case unicode.categories locals combinators.short-circuit
-make combinators io splitting math.parser ;
+make combinators io splitting math.parser math.ranges
+generalizations sorting.functor math.order sorting.slots ;
IN: sequence-parser
TUPLE: sequence-parser sequence n ;
@@ -146,7 +147,7 @@ TUPLE: sequence-parser sequence n ;
CHAR: \ CHAR: " take-token* ;
: take-integer ( sequence-parser -- n/f )
- [ current digit? ] take-while string>number ;
+ [ current digit? ] take-while ;
:: take-n ( sequence-parser n -- seq/f )
n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
@@ -165,5 +166,64 @@ TUPLE: sequence-parser sequence n ;
] if
] with-sequence-parser ;
+: take-c++-comment ( sequence-parser -- seq/f )
+ [
+ dup "//" take-sequence [
+ [
+ [
+ { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+ ] take-until
+ ] [
+ advance drop
+ ] bi
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: c-identifier-begin? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ { CHAR: _ } 3append member? ;
+
+: c-identifier-ch? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ CHAR: 0 CHAR: 9 [a,b]
+ { CHAR: _ } 4 nappend member? ;
+
+: take-c-identifier ( state-parser -- string/f )
+ [
+ dup current c-identifier-begin? [
+ [ current c-identifier-ch? ] take-while
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+ { length>=< <=> } sort-by ;
+
+: take-first-matching ( state-parser seq -- seq )
+ swap
+ '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
+
+
+: take-longest ( state-parser seq -- seq )
+ sort-tokens take-first-matching ;
+
+: take-c-integer ( state-parser -- string/f )
+ [
+ dup take-integer [
+ swap
+ { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
+ take-longest [ append ] when*
+ ] [
+ drop f
+ ] if*
+ ] with-sequence-parser ;
+
: write-full ( sequence-parser -- ) sequence>> write ;
: write-rest ( sequence-parser -- ) take-rest write ;
From cd2ce4c9ae57c3257706ddb5b0cb6b576fed5849 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 11 Apr 2009 09:03:00 -0500
Subject: [PATCH 29/33] fix blob selects in db.tuples
---
basis/db/queries/queries.factor | 5 ++++-
basis/db/tuples/tuples-tests.factor | 19 +++++++++++++++++++
2 files changed, 23 insertions(+), 1 deletion(-)
diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor
index 2730340bfc..c4aa47d383 100755
--- a/basis/db/queries/queries.factor
+++ b/basis/db/queries/queries.factor
@@ -4,7 +4,7 @@ USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types classes words shuffle arrays
destructors continuations db.tuples.private prettyprint
-db.private ;
+db.private byte-arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
@@ -115,6 +115,9 @@ M: sequence where ( spec obj -- )
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
+M: byte-array where ( spec obj -- )
+ over column-name>> 0% " = " 0% bind# ;
+
M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ;
diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor
index 50d7f044d1..d4a58fa4fc 100644
--- a/basis/db/tuples/tuples-tests.factor
+++ b/basis/db/tuples/tuples-tests.factor
@@ -634,3 +634,22 @@ compound-foo "COMPOUND_FOO"
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
+
+
+TUPLE: example id data ;
+
+example "EXAMPLE"
+{
+ { "id" "ID" +db-assigned-id+ }
+ { "data" "DATA" BLOB }
+} define-persistent
+
+: test-blob-select ( -- )
+ example ensure-table
+ [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
+ [
+ T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
+ ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
+
+[ test-blob-select ] test-sqlite
+[ test-blob-select ] test-postgresql
From 9ac2214b627636762c28b9edbf50ca8c1be8e20a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 11 Apr 2009 12:11:00 -0500
Subject: [PATCH 30/33] fix html.parser
---
extra/html/parser/parser.factor | 44 ++++++++++++++++-----------------
1 file changed, 22 insertions(+), 22 deletions(-)
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index b1dc4de4df..d95c79dd88 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -37,89 +37,89 @@ SYMBOL: tagstack
swap >>name
swap >>text ; inline
-: (read-quote) ( state-parser ch -- string )
+: (read-quote) ( sequence-parser ch -- string )
'[ [ current _ = ] take-until ] [ advance drop ] bi ;
-: read-single-quote ( state-parser -- string )
+: read-single-quote ( sequence-parser -- string )
CHAR: ' (read-quote) ;
-: read-double-quote ( state-parser -- string )
+: read-double-quote ( sequence-parser -- string )
CHAR: " (read-quote) ;
-: read-quote ( state-parser -- string )
+: read-quote ( sequence-parser -- string )
dup get+increment CHAR: ' =
[ read-single-quote ] [ read-double-quote ] if ;
-: read-key ( state-parser -- string )
+: read-key ( sequence-parser -- string )
skip-whitespace
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
-: read-token ( state-parser -- string )
+: read-token ( sequence-parser -- string )
[ current blank? ] take-until ;
-: read-value ( state-parser -- string )
+: read-value ( sequence-parser -- string )
skip-whitespace
dup current quote? [ read-quote ] [ read-token ] if
[ blank? ] trim ;
-: read-comment ( state-parser -- )
+: read-comment ( sequence-parser -- )
"-->" take-until-sequence comment new-tag push-tag ;
-: read-dtd ( state-parser -- )
+: read-dtd ( sequence-parser -- )
">" take-until-sequence dtd new-tag push-tag ;
-: read-bang ( state-parser -- )
+: read-bang ( sequence-parser -- )
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
[ advance advance read-comment ] [ read-dtd ] if ;
-: read-tag ( state-parser -- string )
+: read-tag ( sequence-parser -- string )
[ [ current "><" member? ] take-until ]
[ dup current CHAR: < = [ advance ] unless drop ] bi ;
-: read-until-< ( state-parser -- string )
+: read-until-< ( sequence-parser -- string )
[ current CHAR: < = ] take-until ;
-: parse-text ( state-parser -- )
+: parse-text ( sequence-parser -- )
read-until-< [ text new-tag push-tag ] unless-empty ;
-: parse-key/value ( state-parser -- key value )
+: parse-key/value ( sequence-parser -- key value )
[ read-key >lower ]
[ skip-whitespace "=" take-sequence ]
[ swap [ read-value ] [ drop dup ] if ] tri ;
-: (parse-attributes) ( state-parser -- )
+: (parse-attributes) ( sequence-parser -- )
skip-whitespace
- dup state-parse-end? [
+ dup sequence-parse-end? [
drop
] [
[ parse-key/value swap set ] [ (parse-attributes) ] bi
] if ;
-: parse-attributes ( state-parser -- hashtable )
+: parse-attributes ( sequence-parser -- hashtable )
[ (parse-attributes) ] H{ } make-assoc ;
: (parse-tag) ( string -- string' hashtable )
[
[ read-token >lower ] [ parse-attributes ] bi
- ] state-parse ;
+ ] parse-sequence ;
-: read-< ( state-parser -- string/f )
+: read-< ( sequence-parser -- string/f )
advance dup current [
CHAR: ! = [ read-bang f ] [ read-tag ] if
] [
drop f
] if* ;
-: parse-tag ( state-parser -- )
+: parse-tag ( sequence-parser -- )
read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
-: (parse-html) ( state-parser -- )
+: (parse-html) ( sequence-parser -- )
dup peek-next [
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
] [ drop ] if ;
: tag-parse ( quot -- vector )
- V{ } clone tagstack [ state-parse ] with-variable ; inline
+ V{ } clone tagstack [ parse-sequence ] with-variable ; inline
PRIVATE>
From 7f80b52619e9f255e486cc913942a8efcd91bb95 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 11 Apr 2009 12:12:09 -0500
Subject: [PATCH 31/33] fix base64
---
basis/base64/base64.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor
index 111fe49f95..47147fa306 100644
--- a/basis/base64/base64.factor
+++ b/basis/base64/base64.factor
@@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
IN: base64
+ERROR: malformed-base64 ;
+
<PRIVATE
: read1-ignoring ( ignoring -- ch )
@@ -18,8 +20,6 @@ IN: base64
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
nth ; inline
-ERROR: malformed-base64 ;
-
: base64>ch ( ch -- ch )
{
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
From ef095f5eef97a3592f883dec9a03e268ee8f4944 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 11 Apr 2009 14:28:48 -0500
Subject: [PATCH 32/33] Check return value of fread and fwrite in image.c
---
vm/image.c | 29 +++++++++++------------------
1 file changed, 11 insertions(+), 18 deletions(-)
diff --git a/vm/image.c b/vm/image.c
index 5ce7147200..a1987180d0 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -86,7 +86,8 @@ void load_image(F_PARAMETERS *p)
}
F_HEADER h;
- fread(&h,sizeof(F_HEADER),1,file);
+ if(fread(&h,sizeof(F_HEADER),1,file) != 1)
+ fatal_error("Cannot read image header",0);
if(h.magic != IMAGE_MAGIC)
fatal_error("Bad image: magic number check failed",h.magic);
@@ -145,27 +146,19 @@ bool save_image(const F_CHAR *filename)
h.userenv[i] = userenv[i];
}
- fwrite(&h,sizeof(F_HEADER),1,file);
+ bool ok = true;
- if(fwrite((void*)tenured->start,h.data_size,1,file) != 1)
+ if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false;
+ if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
+ if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false;
+ if(fclose(file)) ok = false;
+
+ if(!ok)
{
- print_string("Save data heap failed: "); print_string(strerror(errno)); nl();
- return false;
+ print_string("save-image failed: "); print_string(strerror(errno)); nl();
}
- if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1)
- {
- print_string("Save code heap failed: "); print_string(strerror(errno)); nl();
- return false;
- }
-
- if(fclose(file))
- {
- print_string("Failed to close image file: "); print_string(strerror(errno)); nl();
- return false;
- }
-
- return true;
+ return ok;
}
void primitive_save_image(void)
From db3818814dc9d76f365ba2a39113dddf6287de4c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Sat, 11 Apr 2009 15:17:08 -0500
Subject: [PATCH 33/33] Refactor GLU usages in basis, and move opengl.glu to
extra, and don't like VM with GLU
---
basis/opengl/authors.txt | 1 +
basis/opengl/gl/authors.txt | 2 +-
basis/opengl/glu/authors.txt | 1 -
basis/opengl/opengl.factor | 24 +++++++++++++++++-------
basis/ui/render/render.factor | 4 ++--
extra/4DNav/camera/camera.factor | 2 +-
extra/opengl/glu/authors.txt | 1 +
{basis => extra}/opengl/glu/glu.factor | 14 +++++++++++++-
{basis => extra}/opengl/glu/summary.txt | 0
{basis => extra}/opengl/glu/tags.txt | 0
vm/Config.unix | 2 +-
11 files changed, 37 insertions(+), 14 deletions(-)
delete mode 100644 basis/opengl/glu/authors.txt
create mode 100644 extra/opengl/glu/authors.txt
rename {basis => extra}/opengl/glu/glu.factor (97%)
rename {basis => extra}/opengl/glu/summary.txt (100%)
rename {basis => extra}/opengl/glu/tags.txt (100%)
diff --git a/basis/opengl/authors.txt b/basis/opengl/authors.txt
index 55ac3c728e..f4e25322b8 100644
--- a/basis/opengl/authors.txt
+++ b/basis/opengl/authors.txt
@@ -1,3 +1,4 @@
Slava Pestov
Eduardo Cavazos
Joe Groff
+Alex Chapman
diff --git a/basis/opengl/gl/authors.txt b/basis/opengl/gl/authors.txt
index 1901f27a24..e9c193bac7 100644
--- a/basis/opengl/gl/authors.txt
+++ b/basis/opengl/gl/authors.txt
@@ -1 +1 @@
-Slava Pestov
+Alex Chapman
diff --git a/basis/opengl/glu/authors.txt b/basis/opengl/glu/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/opengl/glu/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index c60917b42a..72ca8b8cdb 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -3,7 +3,7 @@
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros
-namespaces math.vectors math.parser opengl.gl opengl.glu combinators
+namespaces math.vectors math.parser opengl.gl combinators
combinators.smart arrays sequences splitting words byte-arrays assocs
colors colors.constants accessors generalizations locals fry
specialized-arrays.float specialized-arrays.uint ;
@@ -16,10 +16,23 @@ IN: opengl
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
+: error>string ( n -- string )
+ H{
+ { HEX: 0 "No error" }
+ { HEX: 0501 "Invalid value" }
+ { HEX: 0500 "Invalid enumerant" }
+ { HEX: 0502 "Invalid operation" }
+ { HEX: 0503 "Stack overflow" }
+ { HEX: 0504 "Stack underflow" }
+ { HEX: 0505 "Out of memory" }
+ } at "Unknown error" or ;
+
+TUPLE: gl-error code string ;
+
: gl-error ( -- )
- glGetError dup zero? [
- "GL error: " over gluErrorString append throw
- ] unless drop ;
+ glGetError dup 0 = [ drop ] [
+ dup error>string \ gl-error boa throw
+ ] if ;
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
@@ -151,9 +164,6 @@ MACRO: all-enabled-client-state ( seq quot -- )
MACRO: set-draw-buffers ( buffers -- )
words>values '[ _ (set-draw-buffers) ] ;
-: gl-look-at ( eye focus up -- )
- [ first3 ] tri@ gluLookAt ;
-
: gen-dlist ( -- id ) 1 glGenLists ;
: make-dlist ( type quot -- id )
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index 09c26fd271..c4e6f56886 100755
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.rectangles math.vectors namespaces kernel accessors
-assocs combinators sequences opengl opengl.gl opengl.glu colors
+assocs combinators sequences opengl opengl.gl colors
colors.constants ui.gadgets ui.pens ;
IN: ui.render
@@ -22,7 +22,7 @@ SYMBOL: viewport-translation
dim>>
[ { 0 1 } v* viewport-translation set ]
[ [ { 0 0 } ] dip gl-viewport ]
- [ [ 0 ] dip first2 0 gluOrtho2D ] tri
+ [ [ 0 ] dip first2 0 1 -1 glOrtho ] tri
]
[ clip set ] bi
do-clip ;
diff --git a/extra/4DNav/camera/camera.factor b/extra/4DNav/camera/camera.factor
index 1f36a46275..0d46d73f55 100755
--- a/extra/4DNav/camera/camera.factor
+++ b/extra/4DNav/camera/camera.factor
@@ -1,4 +1,4 @@
-USING: kernel namespaces math.vectors opengl 4DNav.turtle ;
+USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
IN: 4DNav.camera
diff --git a/extra/opengl/glu/authors.txt b/extra/opengl/glu/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/opengl/glu/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/basis/opengl/glu/glu.factor b/extra/opengl/glu/glu.factor
similarity index 97%
rename from basis/opengl/glu/glu.factor
rename to extra/opengl/glu/glu.factor
index d603724a55..fe060e3553 100644
--- a/basis/opengl/glu/glu.factor
+++ b/extra/opengl/glu/glu.factor
@@ -1,8 +1,17 @@
! Copyright (C) 2005 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel sequences words ;
+USING: alien alien.libraries alien.syntax kernel sequences words system
+combinators ;
IN: opengl.glu
+os {
+ { [ dup macosx? ] [ drop ] }
+ { [ dup windows? ] [ drop ] }
+ { [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
+} cond
+
+LIBRARY: glu
+
! These are defined as structs in glu.h, but we only ever use pointers to them
TYPEDEF: void* GLUnurbs*
TYPEDEF: void* GLUquadric*
@@ -253,3 +262,6 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo
! FUNCTION: GLint gluBuild3DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, void* data ) ;
! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+
+: gl-look-at ( eye focus up -- )
+ [ first3 ] tri@ gluLookAt ;
\ No newline at end of file
diff --git a/basis/opengl/glu/summary.txt b/extra/opengl/glu/summary.txt
similarity index 100%
rename from basis/opengl/glu/summary.txt
rename to extra/opengl/glu/summary.txt
diff --git a/basis/opengl/glu/tags.txt b/extra/opengl/glu/tags.txt
similarity index 100%
rename from basis/opengl/glu/tags.txt
rename to extra/opengl/glu/tags.txt
diff --git a/vm/Config.unix b/vm/Config.unix
index 339c3c3ffb..1f48847542 100644
--- a/vm/Config.unix
+++ b/vm/Config.unix
@@ -14,7 +14,7 @@ PLAF_EXE_OBJS += vm/main-unix.o
ifdef NO_UI
X11_UI_LIBS =
else
- X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lGLU -lX11
+ X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lX11
endif
# CFLAGS += -fPIC