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

basis/tools/scaffold/scaffold-docs.factor

@@ -0,0 +1,47 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings words ;
+IN: tools.scaffold
+
+HELP: developer-name
+{ $description "Set this symbol to hold your name so that the scaffold tools can generate the correct file header for copyright. Setting this variable in your .factor-boot-rc file is recommended." }
+{ $unchecked-example "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
+
+HELP: help.
+{ $values
+     { "word" word } }
+{ $description "Prints out scaffold help markup for a given word." } ;
+
+HELP: scaffold-help
+{ $values
+     { "vocab-root" "a vocabulary root string" } { "string" string } }
+{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ;
+
+HELP: scaffold-undocumented
+{ $values
+     { "string" string } }
+{ $description "Prints scaffolding documenation for undocumented words in a vocabuary except for automatically generated class predicates." } ;
+
+{ scaffold-help scaffold-undocumented } related-words
+
+HELP: scaffold-vocab
+{ $values
+     { "vocab-root" "a vocabulary root string" } { "string" string } }
+{ $description "Creates a direcory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
+
+HELP: using
+{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
+
+ARTICLE: "tools.scaffold" "Scaffold tool"
+"Scaffold setup:"
+{ $subsection developer-name }
+"Generate new vocabs:"
+{ $subsection scaffold-vocab }
+"Generate help scaffolding:"
+{ $subsection scaffold-help }
+{ $subsection scaffold-undocumented }
+{ $subsection help. }
+"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead."
+;
+
+ABOUT: "tools.scaffold"

basis/tools/scaffold/scaffold.factor

@@ -4,19 +4,21 @@ USING: assocs io.files hashtables kernel namespaces sequences
 vocabs.loader io combinators io.encodings.utf8 calendar accessors
 math.parser io.streams.string ui.tools.operations quotations
 strings arrays prettyprint words vocabs sorting sets cords
-sequences.lib combinators.lib ;
+classes sequences.lib combinators.lib ;
 IN: tools.scaffold
 
 SYMBOL: developer-name
 SYMBOL: using
 
 ERROR: not-a-vocab-root string ;
+ERROR: vocab-name-contains-separator path ;
+ERROR: vocab-name-contains-dot path ;
+ERROR: no-vocab vocab ;
 
+<PRIVATE
 : root? ( string -- ? )
     vocab-roots get member?  ;
 
-ERROR: vocab-name-contains-separator path ;
-ERROR: vocab-name-contains-dot path ;
 : check-vocab-name ( string -- string )
     dup dup [ CHAR: . = ] trim [ length ] bi@ =
     [ vocab-name-contains-dot ] unless
@@ -109,7 +111,7 @@ ERROR: vocab-name-contains-dot path ;
     } at* ;
 
 : add-using ( object -- )
-    vocabulary>> using get conjoin ;
+    vocabulary>> using get [ conjoin ] [ drop ] if* ;
 
 : ($values.) ( array -- )
     [
@@ -140,18 +142,26 @@ ERROR: vocab-name-contains-dot path ;
 
 : $description. ( word -- )
     drop
-    "{ $description } ;" print ;
+    "{ $description \"\" } ;" print ;
 
 : help-header. ( word -- )
     "HELP: " write name>> print ;
 
-: help. ( word -- )
+: (help.) ( word -- )
     [ help-header. ] [ $values. ] [ $description. ] tri ;
 
+: interesting-words ( vocab -- array )
+    words
+    [ [ "help" word-prop ] [ predicate? ] bi or not ] filter
+    natural-sort ;
+
+: interesting-words. ( vocab -- )
+    interesting-words [ (help.) nl ] each ;
+
 : help-file-string ( str1 -- str2 )
     [
         [ "IN: " write print nl ]
-        [ words natural-sort [ help. nl ] each ]
+        [ interesting-words. ]
         [ "ARTICLE: " write unparse dup write bl print ";" print nl ]
         [ "ABOUT: " write unparse print ] quad
     ] with-string-writer ;
@@ -178,12 +188,33 @@ ERROR: vocab-name-contains-dot path ;
 : prepare-scaffold ( vocab-root string -- string path )
     check-scaffold [ vocab>scaffold-path ] keep ;
 
+: with-scaffold ( quot -- )
+    [ H{ } clone using ] dip with-variable ; inline
+
+: check-vocab ( vocab -- vocab )
+    dup find-vocab-root [ no-vocab ] unless ;
+PRIVATE>
+
+: link-vocab ( vocab -- )
+    check-vocab
+    "Edit documentation: " write
+    [ find-vocab-root ] keep
+    [ append-path ] keep "-docs.factor" append append-path
+    <pathname> . ;
+
+: help. ( word -- )
+    [ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
+
 : scaffold-help ( vocab-root string -- )
-    H{ } clone using [
+    [
+        check-vocab
         prepare-scaffold
         [ "-docs.factor" scaffold-path ] dip
         swap [ set-scaffold-help-file ] [ 2drop ] if
-    ] with-variable ;
+    ] with-scaffold ;
+
+: scaffold-undocumented ( string -- )
+    [ interesting-words. ] [ link-vocab ] bi ;
 
 : scaffold-vocab ( vocab-root string -- )
     prepare-scaffold

basis/windows/dinput/constants/constants.factor

@@ -22,7 +22,7 @@ SYMBOLS:
 : (offsetof) ( field struct -- offset )
     [ (field-spec-of) offset>> ] [ drop 0 ] if* ;
 : (sizeof) ( field struct -- size )
-    [ (field-spec-of) class>> "[" split1 drop heap-size ] [ drop 1 ] if* ;
+    [ (field-spec-of) type>> "[" split1 drop heap-size ] [ drop 1 ] if* ;
 
 : (flag) ( thing -- integer )
     {

extra/graphics/bitmap/bitmap.factor

@@ -4,7 +4,8 @@
 USING: alien arrays byte-arrays combinators summary
 io.backend graphics.viewer io io.binary io.files kernel libc
 math math.functions namespaces opengl opengl.gl prettyprint
-sequences strings ui ui.gadgets.panes io.encodings.binary ;
+sequences strings ui ui.gadgets.panes io.encodings.binary
+accessors ;
 IN: graphics.bitmap
 
 ! Currently can only handle 24bit bitmaps.
@@ -31,36 +32,35 @@ M: bitmap-magic summary
     drop "First two bytes of bitmap stream must be 'BM'" ;
 
 : parse-file-header ( bitmap -- )
-    2 read >string dup "BM" = [ bitmap-magic ] unless
+    2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
-        over set-bitmap-magic
+    4 read le> >>size
-    4 read le> over set-bitmap-size
+    4 read le> >>reserved
-    4 read le> over set-bitmap-reserved
+    4 read le> >>offset drop ;
-    4 read le> swap set-bitmap-offset ;
 
 : parse-bitmap-header ( bitmap -- )
-    4 read le> over set-bitmap-header-length
+    4 read le> >>header-length
-    4 read le> over set-bitmap-width
+    4 read le> >>width
-    4 read le> over set-bitmap-height
+    4 read le> >>height
-    2 read le> over set-bitmap-planes
+    2 read le> >>planes
-    2 read le> over set-bitmap-bit-count
+    2 read le> >>bit-count
-    4 read le> over set-bitmap-compression
+    4 read le> >>compression
-    4 read le> over set-bitmap-size-image
+    4 read le> >>size-image
-    4 read le> over set-bitmap-x-pels
+    4 read le> >>x-pels
-    4 read le> over set-bitmap-y-pels
+    4 read le> >>y-pels
-    4 read le> over set-bitmap-color-used
+    4 read le> >>color-used
-    4 read le> swap set-bitmap-color-important ;
+    4 read le> >>color-important drop ;
 
 : rgb-quads-length ( bitmap -- n )
-    [ bitmap-offset 14 - ] keep bitmap-header-length - ;
+    [ offset>> 14 - ] keep header-length>> - ;
 
 : color-index-length ( bitmap -- n )
-    [ bitmap-width ] keep [ bitmap-planes * ] keep
+    [ width>> ] keep [ planes>> * ] keep
-    [ bitmap-bit-count * 31 + 32 /i 4 * ] keep
+    [ bit-count>> * 31 + 32 /i 4 * ] keep
-    bitmap-height abs * ;
+    height>> abs * ;
 
 : parse-bitmap ( bitmap -- )
-    dup rgb-quads-length read over set-bitmap-rgb-quads
+    dup rgb-quads-length read >>rgb-quads
-    dup color-index-length read swap set-bitmap-color-index ;
+    dup color-index-length read >>color-index drop ;
 
 : load-bitmap ( path -- bitmap )
     normalize-path binary [
@@ -69,50 +69,52 @@ M: bitmap-magic summary
         dup parse-bitmap-header
         dup parse-bitmap
     ] with-file-reader
-    dup bitmap-color-index over bitmap-bit-count
+    dup color-index>> over bit-count>>
-    raw-bitmap>string >byte-array over set-bitmap-array ;
+    raw-bitmap>string >byte-array >>array ;
 
 : save-bitmap ( bitmap path -- )
     binary [
         "BM" write
-        dup bitmap-array length 14 + 40 + 4 >le write
+        dup array>> length 14 + 40 + 4 >le write
         0 4 >le write
         54 4 >le write
 
         40 4 >le write
-        dup bitmap-width 4 >le write
+        {
-        dup bitmap-height 4 >le write
+            [ width>> 4 >le write ]
-        dup bitmap-planes 1 or 2 >le write
+            [ height>> 4 >le write ]
-        dup bitmap-bit-count 24 or 2 >le write
+            [ planes>> 1 or 2 >le write ]
-        dup bitmap-compression 0 or 4 >le write
+            [ bit-count>> 24 or 2 >le write ]
-        dup bitmap-size-image 4 >le write
+            [ compression>> 0 or 4 >le write ]
-        dup bitmap-x-pels 4 >le write
+            [ size-image>> 4 >le write ]
-        dup bitmap-y-pels 4 >le write
+            [ x-pels>> 4 >le write ]
-        dup bitmap-color-used 4 >le write
+            [ y-pels>> 4 >le write ]
-        dup bitmap-color-important 4 >le write
+            [ color-used>> 4 >le write ]
-        dup bitmap-rgb-quads write
+            [ color-important>> 4 >le write ]
-        bitmap-color-index write
+            [ rgb-quads>> write ]
+            [ color-index>> write ]
+        } cleave
     ] with-file-writer ;
 
 M: bitmap draw-image ( bitmap -- )
-    dup bitmap-height 0 < [
+    dup height>> 0 < [
         0 0 glRasterPos2i
         1.0 -1.0 glPixelZoom
     ] [
-        0 over bitmap-height abs glRasterPos2i
+        0 over height>> abs glRasterPos2i
         1.0 1.0 glPixelZoom
     ] if
-    [ bitmap-width ] keep
+    [ width>> ] keep
     [
-        [ bitmap-height abs ] keep
+        [ height>> abs ] keep
-        bitmap-bit-count {
+        bit-count>> {
             ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
             { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
         } case
-    ] keep bitmap-array glDrawPixels ;
+    ] keep array>> glDrawPixels ;
 
-M: bitmap width ( bitmap -- ) bitmap-width ;
+M: bitmap width ( bitmap -- ) width>> ;
-M: bitmap height ( bitmap -- ) bitmap-height ;
+M: bitmap height ( bitmap -- ) height>> ;
 
 : bitmap. ( path -- )
     load-bitmap <graphics-gadget> gadget. ;

extra/graphics/viewer/viewer.factor

@@ -1,26 +1,21 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: arrays kernel math math.functions namespaces opengl
-ui.gadgets ui.render ;
+ui.gadgets ui.render accessors ;
 IN: graphics.viewer
 
-TUPLE: graphics-gadget image ;
+TUPLE: graphics-gadget < gadget image ;
 
 GENERIC: draw-image ( image -- )
 GENERIC: width ( image -- w )
 GENERIC: height ( image -- h )
 
 M: graphics-gadget pref-dim*
-    graphics-gadget-image
+    image>> [ width ] keep height abs 2array ;
-    [ width ] keep height abs 2array ;
 
 M: graphics-gadget draw-gadget* ( gadget -- )
-    origin get [
+    origin get [ image>> draw-image ] with-translation ;
-        graphics-gadget-image draw-image
-    ] with-translation ;
 
 : <graphics-gadget> ( bitmap -- gadget )
-    \ graphics-gadget construct-gadget
+    \ graphics-gadget new-gadget
-    [ set-graphics-gadget-image ] keep ;
+        swap >>image ;
-

unfinished/vocab-browser/vocab-browser.factor

@@ -20,18 +20,6 @@ IN: vocab-browser
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: pprint-class ( class -- )
-  [
-    \ TUPLE: pprint-word dup pprint-word
-    dup superclass tuple eq?
-    [ "<" text dup superclass pprint-word ] unless
-    <block "slots" word-prop [ pprint-slot ] each
-    block> pprint-;
-  ]
-  with-pprint nl ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : word-effect-as-string ( word -- string )
   stack-effect dup
     [ effect>string ]
@@ -71,10 +59,21 @@ IN: vocab-browser
     [ drop ]
     [
       "Predicate Classes" $heading nl
-      [ pprint-class ] each
+      ! [ pprint-class ] each
+      [ { [ ] [ superclass ] } 1arr ] map
+      { "CLASS" "SUPERCLASS" } prefix
+      print-table
+    ]
+  if
+
+  dup vocab words [ class? not ] filter [ symbol? ] filter natural-sort
+  dup empty?
+    [ drop ]
+    [
+      "Symbols" $heading nl
+      print-seq
     ]
   if
-  
 
   dup vocab words [ generic? ] filter natural-sort
   dup empty?
@@ -92,6 +91,7 @@ IN: vocab-browser
     [ builtin-class?   not ] filter
     [ tuple-class?     not ] filter
     [ generic?         not ] filter
+    [ symbol?          not ] filter
     [ word?                ] filter
     natural-sort
     [ [ ] [ word-effect-as-string ] bi 2array ] map
@@ -254,6 +254,40 @@ M: load-this-vocab pprint* ( obj -- )
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+M: vocab-author pprint* ( vocab-author -- ) [ name>> ] [ ] bi write-object ;
+
+: $vocab-authors ( seq -- )
+  drop all-authors [ vocab-author boa ] map print-seq ;
+
+ARTICLE: "vocab-authors" "Vocabulary Authors" { $vocab-authors } ;
+
+: vocabs-by-author ( author -- vocab-names )
+  authored values concat [ name>> ] map ;
+
+: $vocabs-by-author ( seq -- )
+  first name>> vocabs-by-author print-these-vocabs ;
+
+M: vocab-author article-content ( vocab-author -- content )
+   { $vocabs-by-author } swap suffix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: vocab-tag pprint* ( vocab-tag -- ) [ name>> ] [ ] bi write-object ;
+
+: print-vocab-tags ( -- ) all-tags [ vocab-tag boa ] map print-seq ;
+
+: $vocab-tags ( seq -- ) drop print-vocab-tags ;
+
+ARTICLE: "vocab-tags" "Vocabulary Tags" { $vocab-tags } ;
+
+: $vocabs-with-tag ( seq -- )
+  first tagged values concat [ name>> ] map print-these-vocabs ;
+
+M: vocab-tag article-content ( vocab-tag -- content )
+   name>> { $vocabs-with-tag } swap suffix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 ARTICLE: "vocab-index-all"      "All Vocabularies"      { $all-vocabs    } ;
 ARTICLE: "vocab-index-loaded"   "Loaded Vocabularies"   { $loaded-vocabs } ;
 ARTICLE: "vocab-index-unloaded" "Unloaded Vocabularies" { $loaded-vocabs } ;
@@ -268,4 +302,9 @@ ARTICLE: "vocab-indices" "Vocabulary Indices"
   { $subsection "vocab-index-extra"    }
   { $subsection "vocab-index-all"      }
   { $subsection "vocab-index-loaded"   }
-  { $subsection "vocab-index-unloaded" } ;
+  { $subsection "vocab-index-unloaded" }
+  { $subsection "vocab-authors"        }
+  { $subsection "vocab-tags"           } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+