From 9c9132297f44b9a5b629ac17f85b75a7451eeeaf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Jul 2009 20:57:22 -0500 Subject: [PATCH 1/4] no need to call set-gpu-state* directly --- extra/gpu/demos/bunny/bunny.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index f975b21245..48f74df6ce 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -221,7 +221,7 @@ BEFORE: bunny-world begin-world bunny-uniforms boa ; : draw-bunny ( world -- ) - T{ depth-state { comparison cmp-less } } set-gpu-state* + T{ depth-state { comparison cmp-less } } set-gpu-state [ sobel>> framebuffer>> { @@ -247,7 +247,7 @@ BEFORE: bunny-world begin-world sobel-uniforms boa ; : draw-sobel ( world -- ) - T{ depth-state { comparison f } } set-gpu-state* + T{ depth-state { comparison f } } set-gpu-state sobel>> { { "primitive-mode" [ drop triangle-strip-mode ] } @@ -260,7 +260,7 @@ BEFORE: bunny-world begin-world [ draw-bunny ] [ draw-sobel ] bi ; : draw-loading ( world -- ) - T{ depth-state { comparison f } } set-gpu-state* + T{ depth-state { comparison f } } set-gpu-state loading>> { { "primitive-mode" [ drop triangle-strip-mode ] } From dd3c90bf1182fd94039e26ccb1853daddaa3beeb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Jul 2009 20:58:32 -0500 Subject: [PATCH 2/4] add file-stem word to io.pathnames as the counterpart to file-extension. write docs for both --- core/io/pathnames/pathnames-docs.factor | 20 ++++++++++++++++++++ core/io/pathnames/pathnames.factor | 5 ++++- 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index 733283d298..63a905d578 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/core/io/pathnames/pathnames-docs.factor @@ -23,6 +23,24 @@ HELP: file-name { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } } ; +HELP: file-extension +{ $values { "path" "a pathname string" } { "extension" string } } +{ $description "Outputs the extension of " { $snippet "path" } ", or " { $link f } " if the filename has no extension." } +{ $examples + { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-extension ." "f" } + { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-extension ." "\"vbs\"" } +} ; + +HELP: file-stem +{ $values { "path" "a pathname string" } { "stem" string } } +{ $description "Outputs the " { $link file-name } " of " { $snippet "filename" } " with the file extension removed, if any." } +{ $examples + { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-stem ." "\"gcc\"" } + { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-stem ." "\"gui\"" } +} ; + +{ file-name file-stem file-extension } related-words + HELP: path-components { $values { "path" "a pathnames string" } { "seq" sequence } } { $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ; @@ -86,6 +104,8 @@ ARTICLE: "io.pathnames" "Pathname manipulation" "Pathname manipulation:" { $subsection parent-directory } { $subsection file-name } +{ $subsection file-stem } +{ $subsection file-extension } { $subsection last-path-separator } { $subsection path-components } { $subsection prepend-path } diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 30e9e6c206..6a49ed5797 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -118,7 +118,10 @@ PRIVATE> ] if ] unless ; -: file-extension ( filename -- extension ) +: file-stem ( path -- stem ) + file-name "." split1-last drop ; + +: file-extension ( path -- extension ) file-name "." split1-last nip ; : path-components ( path -- seq ) From 918b95dfc75d899046ccf878d9747434409cf11a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 31 Jul 2009 15:34:29 -0500 Subject: [PATCH 3/4] fix some lousy docs in gpu.textures --- extra/gpu/textures/textures-docs.factor | 14 +++++++++----- extra/gpu/textures/textures.factor | 4 ++-- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/extra/gpu/textures/textures-docs.factor b/extra/gpu/textures/textures-docs.factor index 8f3bb361a5..6a14a5728b 100644 --- a/extra/gpu/textures/textures-docs.factor +++ b/extra/gpu/textures/textures-docs.factor @@ -1,5 +1,5 @@ ! (c)2009 Joe Groff bsd license -USING: byte-arrays classes gpu.buffers help.markup help.syntax +USING: alien byte-arrays classes gpu.buffers help.markup help.syntax images kernel math ; IN: gpu.textures @@ -228,7 +228,11 @@ HELP: texture-cube-map { texture-cube-map } related-words HELP: texture-data -{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } ". In addition to providing a " { $snippet "ptr" } " to CPU memory or a GPU " { $link buffer-ptr } ", the " { $link texture-data } " object also specifies the " { $link component-order } " and " { $link component-type } " of the referenced data." } +{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } "." +{ $list +{ "The " { $snippet "ptr" } " slot references either CPU memory (as a " { $link byte-array } " or " { $link alien } ") or a GPU " { $link buffer-ptr } " that contains the image data." } +{ "The " { $snippet "component-order" } " and " { $snippet "component-type" } " slots determine the " { $link component-order } " and " { $link component-type } " of the referenced data." } +} } { $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ; { texture-data } related-words @@ -254,15 +258,15 @@ HELP: texture-filter { $class-description { $snippet "texture-filter" } " values are used in a " { $link texture-parameters } " tuple to determine how a texture should be sampled between pixels or between levels of detail. " { $link filter-linear } " selects linear filtering, while " { $link filter-nearest } " selects nearest-neighbor sampling." } ; HELP: texture-parameters -{ $class-description "When a " { $link texture } " is created, the following " { $snippet "texture-parameter" } "s are set to control how the texture is sampled:" +{ $class-description "A " { $snippet "texture-parameters" } " tuple is supplied when constructing a " { $link texture } " to control the wrapping, filtering, and level-of-detail handling of the texture. These tuples have the following slots:" { $list { "The " { $snippet "wrap" } " slot determines how texture coordinates outside the 0.0 to 1.0 range are mapped to the texture image. The slot either contains a single " { $link texture-wrap } " value, which will apply to all three axes, or a sequence of up to three values, which will apply to the S, T, and R axes, respectively." } -{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former controlling filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." } +{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among the sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." } { "The " { $snippet "mag-filter" } " analogously determines how the texture image is filtered when sampled above its highest level of detail." } { "The " { $snippet "min-lod" } " and " { $snippet "max-lod" } " slots contain integer values that will clamp the range of levels of detail that will be sampled from the texture." } { "The " { $snippet "lod-bias" } " slot contains an integer value that will offset the levels of detail that would normally be sampled from the texture." } { "The " { $snippet "base-level" } " slot contains an integer value that identifies the highest level of detail for the image, typically zero." } -{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithm of the dimensions of the highest level of detail image." } +{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithms of the dimensions of the highest level of detail image." } } } ; { texture-parameters set-texture-parameters } related-words diff --git a/extra/gpu/textures/textures.factor b/extra/gpu/textures/textures.factor index c84f3a2123..a2e6ffd440 100644 --- a/extra/gpu/textures/textures.factor +++ b/extra/gpu/textures/textures.factor @@ -26,14 +26,14 @@ TUPLE: cube-map-face { axis cube-map-axis read-only } ; C: cube-map-face -UNION: texture-data-target - texture-1d texture-2d texture-3d cube-map-face ; UNION: texture-1d-data-target texture-1d ; UNION: texture-2d-data-target texture-2d texture-rectangle texture-1d-array cube-map-face ; UNION: texture-3d-data-target texture-3d texture-2d-array ; +UNION: texture-data-target + texture-1d-data-target texture-2d-data-target texture-3d-data-target ; M: texture dispose [ [ delete-texture ] when* f ] change-handle drop ; From 06eeedcb4cc624d418f47689766feb3b8622800f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 31 Jul 2009 21:48:17 -0500 Subject: [PATCH 4/4] change-tracking-tuple class. subclasses will have a "changed?" slot that gets set to true when any slot is modified --- core/classes/classes-docs.factor | 17 ++++++++++- core/classes/classes.factor | 3 ++ core/slots/slots.factor | 28 +++++++++++++------ .../classes/tuple/change-tracking/authors.txt | 1 + .../change-tracking-tests.factor | 10 +++++++ .../change-tracking/change-tracking.factor | 23 +++++++++++++++ .../classes/tuple/change-tracking/summary.txt | 1 + 7 files changed, 74 insertions(+), 9 deletions(-) create mode 100644 extra/classes/tuple/change-tracking/authors.txt create mode 100644 extra/classes/tuple/change-tracking/change-tracking-tests.factor create mode 100644 extra/classes/tuple/change-tracking/change-tracking.factor create mode 100644 extra/classes/tuple/change-tracking/summary.txt diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 109a3b8089..32bf483f72 100644 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -35,6 +35,7 @@ $nl "You can ask a class for its superclass:" { $subsection superclass } { $subsection superclasses } +{ $subsection subclass-of? } "Class predicates can be used to test instances directly:" { $subsection "class-predicates" } "There is a universal class which all objects are an instance of, and an empty class with no instances:" @@ -102,7 +103,21 @@ HELP: superclasses } } ; -{ superclass superclasses } related-words +HELP: subclass-of? +{ $values + { "class" class } + { "superclass" class } + { "?" boolean } +} +{ $description "Outputs a boolean value indicating whether " { $snippet "class" } " is at any level a subclass of " { $snippet "superclass" } "." } +{ $examples + { $example "USING: classes classes.tuple prettyprint words ;" + "tuple-class \\ class subclass-of? ." + "t" + } +} ; + +{ superclass superclasses subclass-of? } related-words HELP: members { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } } diff --git a/core/classes/classes.factor b/core/classes/classes.factor index dfaec95f76..f009368420 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -59,6 +59,9 @@ M: predicate reset-word : superclasses ( class -- supers ) [ superclass ] follow reverse ; +: subclass-of? ( class superclass -- ? ) + swap superclasses member? ; + : members ( class -- seq ) #! Output f for non-classes to work with algebra code dup class? [ "members" word-prop ] [ drop f ] if ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 304ded0adb..9215857018 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -26,8 +26,10 @@ PREDICATE: writer-method < method-body "writing" word-prop ; [ drop define ] 3bi ; -: reader-quot ( slot-spec -- quot ) - [ +GENERIC# reader-quot 1 ( class slot-spec -- quot ) + +M: object reader-quot + nip [ dup offset>> , \ slot , dup class>> object bootstrap-word eq? @@ -51,8 +53,12 @@ PREDICATE: writer-method < method-body "writing" word-prop ; : define-reader ( class slot-spec -- ) [ nip name>> define-reader-generic ] [ - [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri - define-typecheck + { + [ drop ] + [ nip name>> reader-word ] + [ reader-quot ] + [ nip reader-props ] + } 2cleave define-typecheck ] 2bi ; : writer-word ( name -- word ) @@ -83,8 +89,10 @@ ERROR: bad-slot-value value class ; : writer-quot/fixnum ( slot-spec -- ) [ [ >fixnum ] dip ] % writer-quot/check ; -: writer-quot ( slot-spec -- quot ) - [ +GENERIC# writer-quot 1 ( class slot-spec -- quot ) + +M: object writer-quot + nip [ { { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] } { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] } @@ -101,8 +109,12 @@ ERROR: bad-slot-value value class ; : define-writer ( class slot-spec -- ) [ nip name>> define-writer-generic ] [ - [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri - define-typecheck + { + [ drop ] + [ nip name>> writer-word ] + [ writer-quot ] + [ nip writer-props ] + } 2cleave define-typecheck ] 2bi ; : setter-word ( name -- word ) diff --git a/extra/classes/tuple/change-tracking/authors.txt b/extra/classes/tuple/change-tracking/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/classes/tuple/change-tracking/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/classes/tuple/change-tracking/change-tracking-tests.factor b/extra/classes/tuple/change-tracking/change-tracking-tests.factor new file mode 100644 index 0000000000..e0289500bc --- /dev/null +++ b/extra/classes/tuple/change-tracking/change-tracking-tests.factor @@ -0,0 +1,10 @@ +USING: classes.tuple.change-tracking tools.test ; +IN: classes.tuple.change-tracking.tests + +TUPLE: resource < change-tracking-tuple + { pathname string } ; + +: ( pathname -- resource ) f swap resource boa ; + +[ t ] [ "foo" "bar" >>pathname changed?>> ] unit-test +[ f ] [ "foo" [ 123 >>pathname ] [ drop ] recover changed?>> ] unit-test diff --git a/extra/classes/tuple/change-tracking/change-tracking.factor b/extra/classes/tuple/change-tracking/change-tracking.factor new file mode 100644 index 0000000000..3e210922b5 --- /dev/null +++ b/extra/classes/tuple/change-tracking/change-tracking.factor @@ -0,0 +1,23 @@ +! (c)2009 Joe Groff bsd license +USING: accessors classes classes.tuple fry kernel sequences slots ; +IN: classes.tuple.change-tracking + +TUPLE: change-tracking-tuple + { changed? boolean } ; + +PREDICATE: change-tracking-tuple-class < tuple-class + change-tracking-tuple subclass-of? ; + +: changed? ( tuple -- changed? ) changed?>> ; inline +: clear-changed ( tuple -- tuple ) f >>changed? ; inline + +: filter-changed ( sequence -- sequence' ) [ changed? ] filter ; inline + +> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ; + +PRIVATE> + diff --git a/extra/classes/tuple/change-tracking/summary.txt b/extra/classes/tuple/change-tracking/summary.txt new file mode 100644 index 0000000000..3545c4b258 --- /dev/null +++ b/extra/classes/tuple/change-tracking/summary.txt @@ -0,0 +1 @@ +Tuple classes that keep track of when they've been modified