From 1551eacfa2cd47972bbe5e084a82ded6a2b92fbd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 10:44:50 -0500 Subject: [PATCH 1/8] 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 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> : ( image loc -- texture ) over dim>> max-texture-size [ <= ] 2all? [ ] - [ [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file + [ [ max-texture-size tesselate ] dip ] 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 [ ] 2cache ; [ 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 Date: Thu, 9 Apr 2009 10:46:43 -0500 Subject: [PATCH 2/8] 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 a0ba66080d86a9aa624bdabd8c617d9337d2e9d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 03:52:53 -0500 Subject: [PATCH 3/8] 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" " \"project manager\" >>position ;" } "An alternative strategy is to define the most general BOA constructor first:" { $code - ": ( name position -- person )" + ": ( name position -- employee )" " 40000 employee boa ;" } "Now we can define more specific constructors:" { $code - ": ( name -- person )" - " \"manager\" ;" } + ": ( name -- employee )" + " \"manager\" ;" } "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 Date: Fri, 10 Apr 2009 04:01:59 -0500 Subject: [PATCH 4/8] 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 Date: Fri, 10 Apr 2009 04:03:06 -0500 Subject: [PATCH 5/8] 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 Date: Fri, 10 Apr 2009 06:18:29 -0500 Subject: [PATCH 6/8] 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 Date: Fri, 10 Apr 2009 06:19:46 -0500 Subject: [PATCH 7/8] 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>> :> view view world world>NSRect :> 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 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 Date: Fri, 10 Apr 2009 06:20:23 -0500 Subject: [PATCH 8/8] 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 ;