Merge branch 'deploy-resources' of git://factorcode.org/git/factor into deploy-resources

basis/globs/globs-tests.factor

@@ -1,4 +1,4 @@
-USING: tools.test globs ;
+USING: arrays tools.test globs io.pathnames sequences ;
 IN: globs.tests
 
 [ f ] [ "abd" "fdf" glob-matches? ] unit-test
@@ -17,3 +17,24 @@ IN: globs.tests
 [ f ] [ "foo." "*.{xml,txt}" glob-matches? ] unit-test
 [ t ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
 [ t ] [ "foo.{" "*.{" glob-matches? ] unit-test
+
+[ f ] [ "foo" "bar" append-path "*" glob-matches? ] unit-test
+[ t ] [ "foo" "bar" append-path "*" "*" append-path glob-matches? ] unit-test
+[ f ] [ "foo" "bar" append-path "foo?bar" glob-matches? ] unit-test
+[ t ] [ "foo" "bar" append-path "fo?" "bar" append-path glob-matches? ] unit-test
+
+[ f ] [ "foo" glob-pattern? ] unit-test
+[ t ] [ "fo?" glob-pattern? ] unit-test
+[ t ] [ "fo*" glob-pattern? ] unit-test
+[ t ] [ "fo[mno]" glob-pattern? ] unit-test
+[ t ] [ "fo\\*" glob-pattern? ] unit-test
+[ t ] [ "fo{o,bro}" glob-pattern? ] unit-test
+
+"foo" "bar" append-path 1array
+[ { "foo" "bar" "ba?" } path-separator join glob-parent-directory ] unit-test
+
+[ "foo" ] 
+[ { "foo" "b?r" "bas" } path-separator join glob-parent-directory ] unit-test
+
+[ "" ] 
+[ { "f*" "bar" "bas" } path-separator join glob-parent-directory ] unit-test

basis/globs/globs.factor

@@ -1,9 +1,12 @@
 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel regexp.combinators strings unicode.case
+USING: sequences io.pathnames kernel regexp.combinators
-peg.ebnf regexp arrays ;
+strings unicode.case peg.ebnf regexp arrays ;
 IN: globs
 
+: not-path-separator ( -- sep )
+    "[^" path-separator "]" 3append <regexp> ; foldable
+
 EBNF: <glob>
 
 Character = "\\" .:c => [[ c 1string <literal> ]]
@@ -24,8 +27,8 @@ CharClass = "^"?:n Ranges:e => [[ e <or> n [ <not> ] when ]]
 AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]]
                 | Concatenation => [[ 1array ]]
 
-Element = "*" => [[ R/ .*/ ]]
+Element = "*" => [[ not-path-separator <zero-or-more> ]]
-        | "?" => [[ R/ ./ ]]
+        | "?" => [[ not-path-separator ]]
         | "[" CharClass:c "]" => [[ c ]]
         | "{" AlternationBody:b "}" => [[ b <or> ]]
         | Character
@@ -40,3 +43,10 @@ Main = Concatenation End
 
 : glob-matches? ( input glob -- ? )
     [ >case-fold ] bi@ <glob> matches? ;
+
+: glob-pattern? ( string -- ? )
+    [ "\\*?[{" member? ] any? ;
+
+: glob-parent-directory ( glob -- parent-directory )
+    path-components dup [ glob-pattern? ] find drop head
+    path-separator join ;

basis/io/directories/directories-docs.factor

@@ -46,10 +46,18 @@ HELP: directory-files
 { $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } }
 { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
 
+HELP: directory-tree-files
+{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } }
+{ $description "Outputs a sequence of all files and subdirectories inside the directory named by " { $snippet "path" } " or recursively inside its subdirectories." } ;
+
 HELP: with-directory-files
 { $values { "path" "a pathname string" } { "quot" quotation } }
 { $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ".  Restores the current directory after the quotation is called." } ;
 
+HELP: with-directory-tree-files
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Calls the quotation with the recursive directory file names on the stack and with the directory set as the " { $link current-directory } ".  Restores the current directory after the quotation is called." } ;
+
 HELP: with-directory-entries
 { $values { "path" "a pathname string" } { "quot" quotation } }
 { $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ".  Restores the current directory after the quotation is called." } ;

basis/io/directories/directories-tests.factor

@@ -22,6 +22,24 @@ IN: io.directories.tests
     ] with-directory-files
 ] unit-test
 
+[ { "classes/tuple/tuple.factor" } ] [
+    "resource:core" [
+        "." directory-tree-files [ "classes/tuple/tuple.factor" = ] filter
+    ] with-directory
+] unit-test
+
+[ { "classes/tuple" } ] [
+    "resource:core" [
+        "." directory-tree-files [ "classes/tuple" = ] filter
+    ] with-directory
+] unit-test
+
+[ { "classes/tuple/tuple.factor" } ] [
+    "resource:core" [
+        [ "classes/tuple/tuple.factor" = ] filter
+    ] with-directory-tree-files
+] unit-test
+
 [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
 [ ] [ "blahblah" temp-file make-directory ] unit-test
 [ t ] [ "blahblah" temp-file file-info directory? ] unit-test

basis/io/directories/directories.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators destructors io io.backend
+USING: accessors arrays combinators destructors io io.backend
-io.encodings.binary io.files io.pathnames kernel namespaces
+io.encodings.binary io.files io.files.types io.pathnames
-sequences system vocabs.loader fry ;
+kernel namespaces sequences system vocabs.loader fry ;
 IN: io.directories
 
 : set-current-directory ( path -- )
@@ -41,12 +41,26 @@ HOOK: (directory-entries) os ( path -- seq )
 : directory-files ( path -- seq )
     directory-entries [ name>> ] map ;
 
+: directory-tree-files ( path -- seq )
+    dup directory-entries
+    [
+        dup type>> +directory+ =
+        [ name>>
+            [ append-path directory-tree-files ]
+            [ [ prepend-path ] curry map ]
+            [ prefix ] tri
+        ] [ nip name>> 1array ] if
+    ] with map concat ;
+
 : with-directory-entries ( path quot -- )
     '[ "" directory-entries @ ] with-directory ; inline
 
 : with-directory-files ( path quot -- )
     '[ "" directory-files @ ] with-directory ; inline
 
+: with-directory-tree-files ( path quot -- )
+    '[ "" directory-tree-files @ ] with-directory ; inline
+
 ! Touching files
 HOOK: touch-file io-backend ( path -- )
 

basis/tools/deploy/backend/backend.factor

@@ -7,21 +7,15 @@ summary layouts vocabs.loader prettyprint.config prettyprint debugger
 io.streams.c io.files io.files.temp io.pathnames io.directories
 io.directories.hierarchy io.backend quotations io.launcher
 tools.deploy.config tools.deploy.config.editor bootstrap.image
-io.encodings.utf8 destructors accessors hashtables ;
+io.encodings.utf8 destructors accessors hashtables
+vocabs.metadata.resources ;
 IN: tools.deploy.backend
 
 : copy-vm ( executable bundle-name -- vm )
     prepend-path vm over copy-file ;
 
-CONSTANT: theme-path "basis/ui/gadgets/theme/"
+: copy-resources ( manifest name dir -- )
-
+    append-path swap [ copy-vocab-resources ] with each ;
-: copy-theme ( name dir -- )
-    deploy-ui? get [
-        append-path
-        theme-path append-path
-        [ make-directories ]
-        [ theme-path "resource:" prepend swap copy-tree ] bi
-    ] [ 2drop ] if ;
 
 : image-name ( vocab bundle-name -- str )
     prepend-path ".image" append ;
@@ -89,7 +83,7 @@ DEFER: ?make-staging-image
     [ "deploy-config-" prepend temp-file ] bi
     [ utf8 set-file-contents ] keep ;
 
-: deploy-command-line ( image vocab config -- flags )
+: deploy-command-line ( image vocab manifest-file config -- flags )
     [
         bootstrap-profile ?make-staging-image
 
@@ -97,6 +91,7 @@ DEFER: ?make-staging-image
             "-i=" bootstrap-profile staging-image-name append ,
             "-resource-path=" "" resource-path append ,
             "-run=tools.deploy.shaker" ,
+            "-vocab-manifest-out=" prepend ,
             [ "-deploy-vocab=" prepend , ]
             [ make-deploy-config "-deploy-config=" prepend , ] bi
             "-output-image=" prepend ,
@@ -104,8 +99,10 @@ DEFER: ?make-staging-image
         ] { } make
     ] bind ;
 
-: make-deploy-image ( vm image vocab config -- )
+: make-deploy-image ( vm image vocab config -- manifest )
     make-boot-image
-    deploy-command-line run-factor ;
+    over "vocab-manifest-" prepend temp-file
+    [ swap deploy-command-line run-factor ]
+    [ utf8 file-lines ] bi ;
 
 HOOK: deploy* os ( vocab -- )

basis/tools/deploy/deploy-docs.factor

@@ -7,8 +7,14 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application"
 { $subsections
     "deploy-config"
     "deploy-flags"
+    "deploy-resources"
 } ;
 
+ARTICLE: "deploy-resources" "Deployed resource files"
+"To include additional files in your deployed application, specify their names in a vocabulary's " { $snippet "resources.txt" } " file. The " { $snippet "resources.txt" } " file contains one glob pattern per line. These patterns are expanded relative to the vocabulary directory; files outside of the vocabulary directory cannot be referenced. If a file inside the vocabulary directory matches any of these patterns, it will be included in deployed applications that reference the vocabulary. If a subdirectory matches, its contents will be included recursively."
+$nl
+"If the deployed vocabulary includes an icon file for the current platform (" { $snippet "icon.ico" } " on Windows, or " { $snippet "icon.icns" } " on MacOS X), it will be embedded in the deployed application as its GUI icon." ;
+
 ARTICLE: "tools.deploy.usage" "Deploy tool usage"
 "Once the necessary deployment flags have been set, the application can be deployed:"
 { $subsections deploy }

basis/tools/deploy/macosx/macosx.factor

@@ -6,7 +6,7 @@ sequences system tools.deploy.backend tools.deploy.config
 tools.deploy.config.editor assocs hashtables prettyprint
 io.backend.unix cocoa io.encodings.utf8 io.backend
 cocoa.application cocoa.classes cocoa.plists
-combinators ;
+combinators vocabs.metadata vocabs.loader ;
 IN: tools.deploy.macosx
 
 : bundle-dir ( -- dir )
@@ -16,7 +16,7 @@ IN: tools.deploy.macosx
     [ bundle-dir prepend-path swap ] keep
     "Contents" prepend-path append-path copy-tree ;
 
-: app-plist ( executable bundle-name -- assoc )
+: app-plist ( icon? executable bundle-name -- assoc )
     [
         "6.0" "CFBundleInfoDictionaryVersion" set
         "APPL" "CFBundlePackageType" set
@@ -25,9 +25,11 @@ IN: tools.deploy.macosx
 
         [ "CFBundleExecutable" set ]
         [ "org.factor." prepend "CFBundleIdentifier" set ] bi
+
+        [ "Icon.icns" "CFBundleIconFile" set ] when
     ] H{ } make-assoc ;
 
-: create-app-plist ( executable bundle-name -- )
+: create-app-plist ( icon? executable bundle-name -- )
     [ app-plist ] keep
     "Contents/Info.plist" append-path
     write-plist ;
@@ -40,17 +42,24 @@ IN: tools.deploy.macosx
         "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
     ] [ drop ] if ;
 
+: copy-icns ( vocab bundle-name -- icon? )
+    swap dup vocab-mac-icon-path vocab-append-path dup exists?
+    [ swap "Contents/Resources/Icon.icns" append-path copy-file t ]
+    [ 2drop f ] if ;
+
 : create-app-dir ( vocab bundle-name -- vm )
-    [
+    {
-        nip {
+        [
-            [ copy-dll ]
+            nip {
-            [ copy-nib ]
+                [ copy-dll ]
-            [ "Contents/Resources" append-path make-directories ]
+                [ copy-nib ]
-            [ "Contents/Resources" copy-theme ]
+                [ "Contents/Resources" append-path make-directories ]
-        } cleave
+            } cleave
-    ]
+        ]
-    [ create-app-plist ]
+        [ copy-icns ]
-    [ "Contents/MacOS/" append-path copy-vm ] 2tri
+        [ create-app-plist ]
+        [ "Contents/MacOS/" append-path copy-vm ]
+    } 2cleave
     dup OCT: 755 set-file-permissions ;
 
 : deploy.app-image ( vocab bundle-name -- str )
@@ -72,6 +81,7 @@ M: macosx deploy* ( vocab -- )
             [ bundle-name create-app-dir ] keep
             [ bundle-name deploy.app-image ] keep
             namespace make-deploy-image
+            bundle-name "Contents/Resources" copy-resources
             bundle-name show-in-finder
         ] bind
     ] with-directory ;

basis/tools/deploy/shaker/shaker.factor

@@ -1,13 +1,13 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays accessors io.backend io.pathnames io.streams.c
+USING: arrays accessors io.backend io.encodings.utf8 io.files
-init fry namespaces math make assocs kernel parser parser.notes
+io.streams.c init fry namespaces math make assocs kernel parser
-lexer strings.parser vocabs sequences sequences.deep
+parser.notes lexer strings.parser vocabs sequences sequences.deep
 sequences.private words memory kernel.private continuations io
 vocabs.loader system strings sets vectors quotations byte-arrays
 sorting compiler.units definitions generic generic.standard
 generic.single tools.deploy.config combinators classes
-classes.builtin slots.private grouping command-line ;
+classes.builtin slots.private grouping command-line io.pathnames ;
 QUALIFIED: bootstrap.stage2
 QUALIFIED: classes.private
 QUALIFIED: compiler.crossref
@@ -466,7 +466,8 @@ SYMBOL: deploy-vocab
 
 : startup-stripper ( -- )
     t "quiet" set-global
-    f output-stream set-global ;
+    f output-stream set-global
+    V{ "resource:" } clone vocab-roots set-global ;
 
 : next-method* ( method -- quot )
     [ "method-class" word-prop ]
@@ -502,7 +503,12 @@ SYMBOL: deploy-vocab
     "Clearing megamorphic caches" show
     [ clear-megamorphic-cache ] each ;
 
-: strip ( -- )
+: write-vocab-manifest ( vocab-manifest-out -- )
+    "Writing vocabulary manifest to " write dup print flush
+    vocabs swap utf8 set-file-lines ;
+
+: strip ( vocab-manifest-out -- )
+    [ write-vocab-manifest ] when*
     startup-stripper
     strip-libc
     strip-destructors
@@ -536,7 +542,7 @@ SYMBOL: deploy-vocab
         1 exit
     ] recover ; inline
 
-: (deploy) ( final-image vocab config -- )
+: (deploy) ( final-image vocab-manifest-out vocab config -- )
     #! Does the actual work of a deployment in the slave
     #! stage2 image
     [
@@ -549,11 +555,11 @@ SYMBOL: deploy-vocab
                     "ui.debugger" require
                 ] when
             ] unless
-            deploy-vocab set
+            [ deploy-vocab set ] [ require ] [
-            deploy-vocab get require
+                vocab-main [
-            deploy-vocab get vocab-main [
+                    "Vocabulary has no MAIN: word." print flush 1 exit
-                "Vocabulary has no MAIN: word." print flush 1 exit
+                ] unless
-            ] unless
+            ] tri
             strip
             "Saving final image" show
             save-image-and-exit
@@ -562,6 +568,7 @@ SYMBOL: deploy-vocab
 
 : do-deploy ( -- )
     "output-image" get
+    "vocab-manifest-out" get
     "deploy-vocab" get
     "Deploying " write dup write "..." print
     "deploy-config" get parse-file first

basis/tools/deploy/test/test.factor

@@ -7,7 +7,7 @@ IN: tools.deploy.test
     [ "test.image" temp-file delete-file ] ignore-errors
     "resource:" [
         [ vm "test.image" temp-file ] dip
-        dup deploy-config make-deploy-image
+        dup deploy-config make-deploy-image drop
     ] with-directory ;
 
 ERROR: image-too-big actual-size max-size ;

basis/tools/deploy/unix/unix.factor

@@ -7,7 +7,6 @@ tools.deploy.config.editor assocs hashtables prettyprint ;
 IN: tools.deploy.unix
 
 : create-app-dir ( vocab bundle-name -- vm )
-    dup "" copy-theme
     copy-vm
     dup OCT: 755 set-file-permissions ;
 
@@ -20,6 +19,7 @@ M: unix deploy* ( vocab -- )
             [ bundle-name create-app-dir ] keep
             [ bundle-name image-name ] keep
             namespace make-deploy-image
+            bundle-name "" copy-resources
             bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
         ] bind
     ] with-directory ;

basis/tools/deploy/windows/ico/ico.factor

@@ -0,0 +1,72 @@
+USING: accessors alien alien.c-types arrays classes.struct combinators
+io.backend kernel locals math sequences specialized-arrays
+tools.deploy.windows windows.kernel32 windows.types ;
+IN: tools.deploy.windows.ico
+
+<PRIVATE
+
+STRUCT: ico-header
+    { Reserved WORD }
+    { Type WORD }
+    { ImageCount WORD } ;
+
+STRUCT: ico-directory-entry
+    { Width        BYTE  }
+    { Height       BYTE  }
+    { Colors       BYTE  }
+    { Reserved     BYTE  }
+    { Planes       WORD  }
+    { BitsPerPixel WORD  }
+    { ImageSize    DWORD }
+    { ImageOffset  DWORD } ;
+SPECIALIZED-ARRAY: ico-directory-entry
+
+STRUCT: group-directory-entry
+    { Width        BYTE  }
+    { Height       BYTE  }
+    { Colors       BYTE  }
+    { Reserved     BYTE  }
+    { Planes       WORD  }
+    { BitsPerPixel WORD  }
+    { ImageSize    DWORD }
+    { ImageResourceID WORD } ;
+
+: ico>group-directory-entry ( ico i -- group )
+    [ {
+        [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
+        [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
+    } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
+
+: ico-icon ( directory-entry bytes -- subbytes )
+    [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
+
+:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
+    bytes ico-header memory>struct :> header
+
+    ico-header heap-size bytes <displaced-alien> 
+    header ImageCount>> <direct-ico-directory-entry-array> :> directory
+
+    directory dup length iota [ ico>group-directory-entry ] { } 2map-as
+        :> group-directory
+    directory [ bytes ico-icon ] { } map-as :> icon-bytes
+
+    header clone >c-ptr group-directory concat append
+    icon-bytes ; inline
+
+PRIVATE>
+
+:: embed-icon-resource ( exe ico-bytes id -- )
+    exe normalize-path 1 BeginUpdateResource :> hUpdate
+    hUpdate [
+        ico-bytes ico-group-and-icons :> ( group icons )
+        hUpdate RT_GROUP_ICON id 0 group dup byte-length
+        UpdateResource drop
+
+        icons [| icon i |
+            hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
+            UpdateResource drop
+        ] each-index
+
+        hUpdate 0 EndUpdateResource drop
+    ] when ;
+

basis/tools/deploy/windows/windows.factor

@@ -1,11 +1,15 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.pathnames io.directories io.encodings.ascii kernel namespaces
+USING: io io.encodings.binary io.files io.pathnames io.directories
+io.encodings.ascii kernel namespaces
 sequences locals system splitting tools.deploy.backend
 tools.deploy.config tools.deploy.config.editor assocs hashtables
-prettyprint combinators windows.shell32 windows.user32 ;
+prettyprint combinators windows.kernel32 windows.shell32 windows.user32
+alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico ;
 IN: tools.deploy.windows
 
+CONSTANT: app-icon-resource-id "APPICON"
+
 : copy-dll ( bundle-name -- )
     "resource:factor.dll" swap copy-file-into ;
 
@@ -16,20 +20,24 @@ IN: tools.deploy.windows
 
 : create-exe-dir ( vocab bundle-name -- vm )
     dup copy-dll
-    deploy-ui? get [
+    deploy-ui? get ".exe" ".com" ? copy-vm ;
-        [ "" copy-theme ] [ ".exe" copy-vm ] bi
+
-    ] [ ".com" copy-vm ] if ;
+: embed-ico ( vm vocab -- )
+    dup vocab-windows-icon-path vocab-append-path dup exists?
+    [ binary file-contents app-icon-resource-id embed-icon-resource ]
+    [ 2drop ] if ;
 
 M: winnt deploy*
     "resource:" [
         dup deploy-config [
             deploy-name get
-            [
+            {
-                [ create-exe-dir ]
+                [ create-exe-dir dup ]
+                [ drop embed-ico ]
                 [ image-name ]
-                [ drop ]
+                [ drop namespace make-deploy-image ]
-                2tri namespace make-deploy-image
+                [ nip "" copy-resources ]
-            ]
+                [ nip open-in-explorer ]
-            [ nip open-in-explorer ] 2bi
+            } 2cleave 
         ] bind
     ] with-directory ;

basis/ui/gadgets/buttons/buttons.factor

@@ -5,9 +5,9 @@ colors.constants combinators combinators.short-circuit
 combinators.smart fry kernel locals math math.rectangles
 math.vectors models namespaces opengl opengl.gl quotations
 sequences strings ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.labels ui.gadgets.packs ui.gadgets.tracks
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.theme
-ui.gadgets.worlds ui.gestures ui.pens ui.pens.image
+ui.gadgets.tracks ui.gadgets.worlds ui.gestures ui.pens
-ui.pens.solid ui.pens.tile ;
+ui.pens.image ui.pens.solid ui.pens.tile ;
 FROM: models => change-model ;
 IN: ui.gadgets.buttons
 

basis/ui/gadgets/corners/corners.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences namespaces ui.gadgets.frames
-ui.pens.image ui.gadgets.icons ui.gadgets.grids ;
+ui.pens.image ui.gadgets.icons ui.gadgets.grids ui.gadgets.theme ;
 IN: ui.gadgets.corners
 
 CONSTANT: @center { 1 1 }

basis/ui/gadgets/search-tables/search-tables.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel delegate fry sequences models
 combinators.short-circuit models.search models.delay calendar locals
 ui.gestures ui.pens ui.pens.image ui.gadgets.editors ui.gadgets.labels
-ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.tracks
+ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.theme ui.gadgets.tracks
 ui.gadgets.borders ui.gadgets.buttons ui.baseline-alignment ui.gadgets ;
 IN: ui.gadgets.search-tables
 

basis/ui/gadgets/sliders/sliders.factor

@@ -4,7 +4,7 @@ USING: accessors arrays assocs kernel math namespaces sequences
 vectors models models.range math.vectors math.functions quotations
 colors colors.constants math.rectangles fry combinators ui.gestures
 ui.pens ui.gadgets ui.gadgets.buttons ui.gadgets.tracks math.order
-ui.gadgets.icons ui.pens.tile ui.pens.image ;
+ui.gadgets.icons ui.gadgets.theme ui.pens.tile ui.pens.image ;
 IN: ui.gadgets.sliders
 
 TUPLE: slider < track elevator thumb saved line ;

basis/ui/gadgets/tabbed/tabbed.factor

@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: ui.pens ui.gadgets.tracks ui.gadgets.buttons
 ui.gadgets.buttons.private ui.gadgets.books ui.gadgets.packs
-ui.gadgets.borders ui.gadgets.icons ui.gadgets ui.pens.image
+ui.gadgets.borders ui.gadgets.icons ui.gadgets ui.gadgets.theme
-sequences models accessors kernel colors colors.constants ;
+ui.pens.image sequences models accessors kernel colors
+colors.constants ;
 IN: ui.gadgets.tabbed
 
 TUPLE: tabbed-gadget < track tabs book ;

basis/ui/gadgets/theme/authors.txt

@@ -1 +1,2 @@
 Slava Pestov
+Joe Groff

basis/ui/gadgets/theme/resources.txt

@@ -0,0 +1 @@
+*.tiff

basis/ui/gadgets/theme/theme.factor

@@ -0,0 +1,6 @@
+! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
+USING: io.pathnames sequences ui.images ;
+IN: ui.gadgets.theme
+
+: theme-image ( name -- image-name )
+    "vocab:ui/gadgets/theme/" prepend-path ".tiff" append <image-name> ;

basis/ui/pens/image/image.factor

@@ -18,5 +18,3 @@ M: image-pen draw-interior
 
 M: image-pen pen-pref-dim nip image>> image-dim ;
 
-: theme-image ( name -- image-name )
-    "vocab:ui/gadgets/theme/" prepend-path ".tiff" append <image-name> ;

basis/vocabs/metadata/metadata-docs.factor

@@ -18,6 +18,11 @@ ARTICLE: "vocabs.metadata" "Vocabulary metadata"
     set-vocab-tags
     add-vocab-tags
 }
+"Vocabulary resources:"
+{ $subsections
+    vocab-resources
+    set-vocab-resources
+}
 "Getting and setting arbitrary vocabulary metadata:"
 { $subsections
     vocab-file-contents
@@ -50,3 +55,11 @@ HELP: set-vocab-tags
 { $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
 { $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
 
+HELP: vocab-resources
+{ $values { "vocab" "a vocabulary specifier" } { "patterns" "a sequence of glob patterns" } }
+{ $description "Outputs a list of glob patterns matching files that will be deployed with an application that includes " { $snippet "vocab" } ", as specified by the " { $snippet "resources.txt" } " file in the vocabulary's directory. Outputs an empty array if the file doesn't exist." }
+{ $notes "The " { $vocab-link "vocabs.metadata.resources" } " vocabulary contains words that will expand the glob patterns and directory names in " { $snippet "patterns" } " and return all the matching files." } ;
+
+HELP: set-vocab-resources
+{ $values { "patterns" "a sequence of glob patterns" } { "vocab" "a vocabulary specifier" } }
+{ $description "Stores a list of glob patterns matching files that will be deployed with an application that includes " { $snippet "vocab" } " to the " { $snippet "resources.txt" } " file in the vocabulary's directory." } ;

basis/vocabs/metadata/metadata.factor

@@ -19,6 +19,21 @@ MEMO: vocab-file-contents ( vocab name -- seq )
         3append throw
     ] ?if ;
 
+: vocab-windows-icon-path ( vocab -- string )
+    vocab-dir "icon.ico" append-path ;
+
+: vocab-mac-icon-path ( vocab -- string )
+    vocab-dir "icon.icns" append-path ;
+
+: vocab-resources-path ( vocab -- string )
+    vocab-dir "resources.txt" append-path ;
+
+: vocab-resources ( vocab -- patterns )
+    dup vocab-resources-path vocab-file-contents harvest ;
+
+: set-vocab-resources ( patterns vocab -- )
+    dup vocab-resources-path set-vocab-file-contents ;
+
 : vocab-summary-path ( vocab -- string )
     vocab-dir "summary.txt" append-path ;
 

basis/vocabs/metadata/resources/resources-docs.factor

@@ -0,0 +1,26 @@
+! (c)2010 Joe Groff bsd license
+USING: help.markup help.syntax kernel ;
+IN: vocabs.metadata.resources
+
+HELP: expand-vocab-resource-files
+{ $values
+    { "vocab" "a vocabulary specifier" } { "resource-glob-strings" "a sequence of glob patterns" }
+    { "filenames" "a sequence of filenames" }
+}
+{ $description "Matches all the glob patterns in " { $snippet "resource-glob-strings" } " to the set of files inside " { $snippet "vocab" } "'s directory and outputs a sequence containing the individual files and directories that match. Any matching directories will also have their contents recursively included in the output. The paths in the output will be relative to " { $snippet "vocab" } "'s directory." } ;
+
+HELP: vocab-resource-files
+{ $values
+    { "vocab" "a vocabulary specifier" }
+    { "filenames" "a sequence of filenames" }
+}
+{ $description "Outputs a sequence containing the individual resource files and directories that match the patterns specified in " { $snippet "vocab" } "'s " { $snippet "resources.txt" } " file. Any matching directories will also have their contents recursively included in the output. The paths in the output will be relative to " { $snippet "vocab" } "'s directory." } ;
+
+ARTICLE: "vocabs.metadata.resources" "vocabs.metadata.resources"
+"The " { $vocab-link "vocabs.metadata.resources" } " vocabulary contains words to retrieve the full list of files that match the patterns specified in a vocabulary's " { $snippet "resources.txt" } " file."
+{ $subsections
+    vocab-resource-files
+    expand-vocab-resource-files
+} ;
+
+ABOUT: "vocabs.metadata.resources"

basis/vocabs/metadata/resources/resources-tests.factor

@@ -0,0 +1,19 @@
+! (c)2010 Joe Groff bsd license
+USING: sorting tools.test vocabs.metadata.resources ;
+IN: vocabs.metadata.resources.tests
+
+[ { "bar" "bas" "foo" } ]
+[ "vocabs.metadata.resources.test.1" vocab-resource-files natural-sort ] unit-test
+
+[ { "bar.wtf" "foo.wtf" } ]
+[ "vocabs.metadata.resources.test.2" vocab-resource-files natural-sort ] unit-test
+
+[ {
+    "resource-dir"
+    "resource-dir/bar"
+    "resource-dir/bas"
+    "resource-dir/bas/zang"
+    "resource-dir/bas/zim"
+    "resource-dir/buh"
+    "resource-dir/foo"
+} ] [ "vocabs.metadata.resources.test.3" vocab-resource-files natural-sort ] unit-test

basis/vocabs/metadata/resources/resources.factor

@@ -0,0 +1,45 @@
+! (c)2010 Joe Groff bsd license
+USING: arrays fry globs io.directories io.files.info
+io.pathnames kernel regexp sequences vocabs.loader
+vocabs.metadata ;
+IN: vocabs.metadata.resources
+
+<PRIVATE
+
+: (expand-vocab-resource) ( resource-path -- filenames )
+    dup file-info directory?
+    [ dup '[ _ directory-tree-files [ append-path ] with map ] [ prefix ] bi ]
+    [ 1array ] if ;
+
+: filter-resources ( vocab-files resource-globs -- resource-files ) 
+    '[ _ [ matches? ] with any? ] filter ;
+
+: copy-vocab-resource ( to from file -- )
+    [ append-path ] curry bi@
+    dup file-info directory?
+    [ drop make-directories ]
+    [ swap [ parent-directory make-directories ] [ copy-file ] bi ] if ;
+    
+PRIVATE>
+
+: vocab-dir-in-root ( vocab -- dir )
+    [ find-vocab-root ] [ vocab-dir ] bi append-path ;
+
+: expand-vocab-resource-files ( vocab resource-glob-strings -- filenames )
+    [ vocab-dir-in-root ] dip [ <glob> ] map '[
+        _ filter-resources
+        [ (expand-vocab-resource) ] map concat
+    ] with-directory-tree-files ;
+
+: vocab-resource-files ( vocab -- filenames )
+    dup vocab-resources
+    [ drop f ] [ expand-vocab-resource-files ] if-empty ;
+
+: copy-vocab-resources ( dir vocab -- )
+    dup vocab-resource-files 
+    [ 2drop ] [
+        [ [ vocab-dir append-path ] [ vocab-dir-in-root ] bi ] dip
+        [ 2drop make-directories ]
+        [ [ copy-vocab-resource ] with with each ] 3bi
+    ] if-empty ;
+

basis/vocabs/metadata/resources/test/1/1.factor

@@ -0,0 +1,6 @@
+USING: io kernel ;
+IN: vocabs.metadata.resources.test.1
+
+: main ( -- ) "Resources test 1" print ;
+
+MAIN: main

basis/vocabs/metadata/resources/test/1/resources.txt

@@ -0,0 +1,3 @@
+foo
+bar
+bas

basis/vocabs/metadata/resources/test/2/2.factor

@@ -0,0 +1,6 @@
+USING: io kernel ;
+IN: vocabs.metadata.resources.test.2
+
+: main ( -- ) "Resources test 2" print ;
+
+MAIN: main

basis/vocabs/metadata/resources/test/2/resources.txt

@@ -0,0 +1 @@
+*.wtf

basis/vocabs/metadata/resources/test/3/3.factor

@@ -0,0 +1,6 @@
+USING: io kernel ;
+IN: vocabs.metadata.resources.test.3
+
+: main ( -- ) "Resources test 3" print ;
+
+MAIN: main

basis/vocabs/metadata/resources/test/3/resources.txt

@@ -0,0 +1 @@
+resource-dir

basis/windows/kernel32/kernel32.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax kernel windows.types
-multiline classes.struct ;
+math multiline classes.struct ;
 IN: windows.kernel32
 
 CONSTANT: MAX_PATH 260
@@ -787,6 +787,30 @@ CONSTANT: STATUS_CONTROL_C_EXIT             HEX: C000013A
 CONSTANT: STATUS_FLOAT_MULTIPLE_FAULTS      HEX: C00002B4
 CONSTANT: STATUS_FLOAT_MULTIPLE_TRAPS       HEX: C00002B5
 
+! Resource IDs
+: MAKEINTRESOURCE ( int -- resource ) HEX: ffff bitand <alien> ; inline
+
+: RT_CURSOR       ( -- id )  1 MAKEINTRESOURCE ; inline
+: RT_BITMAP       ( -- id )  2 MAKEINTRESOURCE ; inline
+: RT_ICON         ( -- id )  3 MAKEINTRESOURCE ; inline
+: RT_MENU         ( -- id )  4 MAKEINTRESOURCE ; inline
+: RT_DIALOG       ( -- id )  5 MAKEINTRESOURCE ; inline
+: RT_STRING       ( -- id )  6 MAKEINTRESOURCE ; inline
+: RT_FONTDIR      ( -- id )  7 MAKEINTRESOURCE ; inline
+: RT_FONT         ( -- id )  8 MAKEINTRESOURCE ; inline
+: RT_ACCELERATOR  ( -- id )  9 MAKEINTRESOURCE ; inline
+: RT_RCDATA       ( -- id ) 10 MAKEINTRESOURCE ; inline
+: RT_MESSAGETABLE ( -- id ) 11 MAKEINTRESOURCE ; inline
+: RT_GROUP_CURSOR ( -- id ) 12 MAKEINTRESOURCE ; inline
+: RT_GROUP_ICON   ( -- id ) 14 MAKEINTRESOURCE ; inline
+: RT_VERSION      ( -- id ) 16 MAKEINTRESOURCE ; inline
+: RT_DLGINCLUDE   ( -- id ) 17 MAKEINTRESOURCE ; inline
+: RT_PLUGPLAY     ( -- id ) 19 MAKEINTRESOURCE ; inline
+: RT_VXD          ( -- id ) 20 MAKEINTRESOURCE ; inline
+: RT_ANICURSOR    ( -- id ) 21 MAKEINTRESOURCE ; inline
+: RT_ANIICON      ( -- id ) 22 MAKEINTRESOURCE ; inline
+: RT_MANIFEST     ( -- id ) 24 MAKEINTRESOURCE ; inline
+
 LIBRARY: kernel32
 ! FUNCTION: _hread
 ! FUNCTION: _hwrite
@@ -826,7 +850,8 @@ FUNCTION: BOOL AllocConsole ( ) ;
 ! FUNCTION: BaseUpdateAppcompatCache
 ! FUNCTION: Beep
 ! FUNCTION: BeginUpdateResourceA
-! FUNCTION: BeginUpdateResourceW
+FUNCTION: HANDLE BeginUpdateResourceW ( LPCTSTR pFileName, BOOL bDeleteExistingResources ) ;
+ALIAS: BeginUpdateResource BeginUpdateResourceW
 ! FUNCTION: BindIoCompletionCallback
 ! FUNCTION: BuildCommDCBA
 ! FUNCTION: BuildCommDCBAndTimeoutsA
@@ -1013,7 +1038,8 @@ CONSTANT: DUPLICATE_SAME_ACCESS 2
 ! FUNCTION: EncodePointer
 ! FUNCTION: EncodeSystemPointer
 ! FUNCTION: EndUpdateResourceA
-! FUNCTION: EndUpdateResourceW
+FUNCTION: BOOL EndUpdateResourceW ( HANDLE hUpdate, BOOL fDiscard ) ;
+ALIAS: EndUpdateResource EndUpdateResourceW
 ! FUNCTION: EnterCriticalSection
 ! FUNCTION: EnumCalendarInfoA
 ! FUNCTION: EnumCalendarInfoExA
@@ -1831,7 +1857,8 @@ FUNCTION: BOOL UnmapViewOfFile ( LPCVOID lpBaseAddress ) ;
 ! FUNCTION: UnregisterWait
 ! FUNCTION: UnregisterWaitEx
 ! FUNCTION: UpdateResourceA
-! FUNCTION: UpdateResourceW
+FUNCTION: BOOL UpdateResourceW ( HANDLE hUpdate, LPCTSTR lpType, LPCTSTR lpName, WORD wLanguage, LPVOID lpData, DWORD cbData ) ;
+ALIAS: UpdateResource UpdateResourceW
 ! FUNCTION: UTRegister
 ! FUNCTION: UTUnRegister
 ! FUNCTION: ValidateLCType

core/vocabs/loader/loader-docs.factor

@@ -45,12 +45,15 @@ $nl
     { { $snippet "foo/bar/bar-docs.factor" } " - documentation, see " { $link "writing-help" } }
     { { $snippet "foo/bar/bar-tests.factor" } " - unit tests, see " { $link "tools.test" } }
 }
-"Finally, optional three text files may contain meta-data:"
+"Finally, four optional text files may contain metadata:"
 { $list
-    { { $snippet "foo/bar/authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } }
+    { { $snippet "foo/bar/authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } "." }
-    { { $snippet "foo/bar/summary.txt" } " - a one-line description" }
+    { { $snippet "foo/bar/resources.txt" } " - a series of lines with one file glob pattern per line. Files inside the vocabulary directory whose names match any of these glob patterns will be included with the compiled application as " { $link "deploy-resources" } "." }
-    { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can re-use" }
+    { { $snippet "foo/bar/summary.txt" } " - a one-line description." }
+    { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can reuse." }
 }
+"An icon file representing the vocabulary can also be provided. A file named " { $snippet "icon.ico" } " will be used as the application icon when the application is deployed on Windows. A file named " { $snippet "icon.icns" } " will be used when the application is deployed on MacOS X."
+$nl
 "The " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " words load vocabularies which have not been loaded yet, as needed."
 $nl
 "Vocabularies can also be loaded at run time, without altering the vocabulary search path. This is done by calling a word which loads a vocabulary if it is not in the image, doing nothing if it is:"

extra/audio/chunked-file/chunked-file.factor

@@ -24,5 +24,5 @@ ERROR: invalid-audio-file ;
     } case ;
 
 : check-chunk ( chunk id class -- ? )
-    heap-size [ id= ] [ [ length ] dip >= ] bi-curry* bi and ;
+    heap-size [ id= ] [ [ length ] dip >= ] bi-curry* bi and ; inline
 

extra/gpu/demos/bunny/bunny.factor

@@ -3,8 +3,8 @@ USING: accessors alien.c-types arrays classes.struct combinators
 combinators.short-circuit game.loop game.worlds gpu gpu.buffers
 gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
 gpu.textures gpu.util grouping http.client images images.loader
-io io.encodings.ascii io.files io.files.temp kernel locals math
+images.tiff io io.encodings.ascii io.files io.files.temp kernel
-math.matrices math.vectors.simd math.parser math.vectors
+locals math math.matrices math.vectors.simd math.parser math.vectors
 method-chains namespaces sequences splitting threads ui ui.gadgets
 ui.gadgets.worlds ui.pixel-formats specialized-arrays
 specialized-vectors literals ;

extra/gpu/demos/bunny/deploy.factor

@@ -1,14 +1,14 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-name "gpu.demos.bunny" }
+    { deploy-name "Bunny" }
-    { deploy-word-defs? f }
-    { deploy-io 3 }
-    { "stop-after-last-window?" t }
-    { deploy-math? t }
-    { deploy-word-props? f }
-    { deploy-threads? t }
-    { deploy-c-types? f }
-    { deploy-reflection 2 }
-    { deploy-unicode? f }
     { deploy-ui? t }
+    { deploy-c-types? f }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-io 3 }
+    { deploy-reflection 2 }
+    { deploy-word-props? f }
+    { deploy-math? t }
+    { deploy-threads? t }
+    { deploy-word-defs? f }
 }

extra/gpu/demos/bunny/resources.txt

@@ -0,0 +1 @@
+loading.tiff

extra/gpu/demos/raytrace/deploy.factor

@@ -0,0 +1,14 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "Raytrace" }
+    { deploy-ui? t }
+    { deploy-c-types? f }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-io 2 }
+    { deploy-reflection 2 }
+    { deploy-word-props? f }
+    { deploy-math? t }
+    { deploy-threads? t }
+    { deploy-word-defs? f }
+}

extra/gpu/demos/raytrace/resources.txt

@@ -0,0 +1,4 @@
+green-ball.aiff
+mirror-ball.aiff
+red-ball.aiff
+yellow-ball.aiff

extra/gpu/textures/textures-docs.factor

@@ -335,12 +335,16 @@ HELP: compressed-texture-format
 { { $link DXT1-RGBA } }
 { { $link DXT3 } }
 { { $link DXT5 } }
+{ { $link LATC1 } }
+{ { $link LATC1-SIGNED } }
+{ { $link LATC2 } }
+{ { $link LATC2-SIGNED } }
 { { $link RGTC1 } }
 { { $link RGTC1-SIGNED } }
 { { $link RGTC2 } }
 { { $link RGTC2-SIGNED } }
 } }
-{ $notes "The " { $snippet "DXT1" } " formats require either the " { $snippet "GL_EXT_texture_compression_s3tc" } " or " { $snippet "GL_EXT_texture_compression_dxt1" } " extension. The other " { $snippet "DXT" } " formats require the " { $snippet "GL_EXT_texture_compression_s3tc" } " extension. The " { $snippet "RGTC" } " formats require OpenGL 3.0 or later or the " { $snippet "GL_EXT_texture_compression_rgtc" } " extension." } ;
+{ $notes "The " { $snippet "DXT1" } " formats require either the " { $snippet "GL_EXT_texture_compression_s3tc" } " or " { $snippet "GL_EXT_texture_compression_dxt1" } " extension. The other " { $snippet "DXT" } " formats require the " { $snippet "GL_EXT_texture_compression_s3tc" } " extension. The " { $snippet "LATC" } " formats require the " { $snippet "GL_EXT_texture_compression_latc" } " extension. The " { $snippet "RGTC" } " formats require OpenGL 3.0 or later or the " { $snippet "GL_EXT_texture_compression_rgtc" } " extension." } ;
 
 HELP: compressed-texture-data
 { $class-description { $snippet "compressed-texture-data" } " tuples are used to feed compressed texture data to " { $link allocate-compressed-texture } " and " { $link update-compressed-texture } "."

extra/gpu/textures/textures.factor

@@ -51,6 +51,7 @@ UNION: ?float-array float-array POSTPONE: f ;
 
 VARIANT: compressed-texture-format
     DXT1-RGB DXT1-RGBA DXT3 DXT5
+    LATC1 LATC1-SIGNED LATC2 LATC2-SIGNED
     RGTC1 RGTC1-SIGNED RGTC2 RGTC2-SIGNED ;
 
 TUPLE: compressed-texture-data

vm/factor.rs

@@ -1,2 +1,2 @@
-fraptor ICON "misc/icons/Factor.ico"
+APPICON ICON "misc/icons/Factor.ico"