Merge branch 'master' of git://factorcode.org/git/factor

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 } } }

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 ;

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 }

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 )

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 )

extra/classes/tuple/change-tracking/authors.txt

@@ -0,0 +1 @@
+Joe Groff

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 } ;
+
+: <resource> ( pathname -- resource ) f swap resource boa ;
+
+[ t ] [ "foo" <resource> "bar" >>pathname changed?>> ] unit-test
+[ f ] [ "foo" <resource> [ 123 >>pathname ] [ drop ] recover changed?>> ] unit-test

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
+
+<PRIVATE
+
+M: change-tracking-tuple-class writer-quot ( class slot-spec -- )
+    [ call-next-method ]
+    [ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ;
+
+PRIVATE>
+

extra/classes/tuple/change-tracking/summary.txt

@@ -0,0 +1 @@
+Tuple classes that keep track of when they've been modified

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 ] }

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 <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 <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

extra/gpu/textures/textures.factor

@@ -26,14 +26,14 @@ TUPLE: cube-map-face
     { axis cube-map-axis read-only } ;
 C: <cube-map-face> 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 ;