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

basis/help/lint/lint.factor

@@ -132,6 +132,11 @@ SYMBOL: vocabs-quot
         [ check-descriptions ]
     } cleave ;
 
+: check-class-description ( word element -- )
+    [ class? not ]
+    [ { $class-description } swap elements empty? not ] bi* and
+    [ "A word that is not a class has a $class-description" throw ] when ;
+
 : all-word-help ( words -- seq )
     [ word-help ] filter ;
 
@@ -153,7 +158,8 @@ M: help-error error.
         dup '[
             _ dup word-help
             [ check-values ]
-            [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
+            [ check-class-description ]
+            [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
         ] check-something
     ] [ drop ] if ;
 

basis/images/bitmap/bitmap.factor

@@ -108,11 +108,6 @@ M: bitmap-image load-image* ( path bitmap -- bitmap )
     load-bitmap-data process-bitmap-data
     fill-image-slots ;
 
-M: bitmap-image normalize-scan-line-order
-    dup dim>> '[
-        _ first 4 * <sliced-groups> reverse concat
-    ] change-bitmap ;
-
 MACRO: (nbits>bitmap) ( bits -- )
     [ -3 shift ] keep '[
         bitmap-image new
@@ -121,6 +116,7 @@ MACRO: (nbits>bitmap) ( bits -- )
             swap >>width
             swap array-copy [ >>bitmap ] [ >>color-index ] bi
             _ >>bit-count fill-image-slots
+            t >>upside-down?
     ] ;
 
 : bgr>bitmap ( array height width -- bitmap )

basis/images/images.factor

@@ -27,7 +27,7 @@ R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
         { R32G32B32A32 [ 16 ] }
     } case ;
 
-TUPLE: image dim component-order bitmap ;
+TUPLE: image dim component-order upside-down? bitmap ;
 
 : <image> ( -- image ) image new ; inline
 
@@ -82,11 +82,16 @@ M: ARGB normalize-component-order*
 M: ABGR normalize-component-order*
     drop ARGB>RGBA 4 BGR>RGB ;
 
-GENERIC: normalize-scan-line-order ( image -- image )
+: normalize-scan-line-order ( image -- image )
-
+    dup upside-down?>> [
-M: image normalize-scan-line-order ;
+        dup dim>> first 4 * '[
+            _ <groups> reverse concat
+        ] change-bitmap
+        f >>upside-down?
+    ] when ;
 
 : normalize-image ( image -- image )
     [ >byte-array ] change-bitmap
     normalize-component-order
-    normalize-scan-line-order ;
+    normalize-scan-line-order
+    RGBA >>component-order ;

basis/images/tiff/tiff.factor

@@ -503,7 +503,7 @@ ERROR: unknown-component-order ifd ;
 : ifd>image ( ifd -- image )
     {
         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
-        [ ifd-component-order ]
+        [ ifd-component-order f ]
         [ bitmap>> ]
     } cleave tiff-image boa ;
 

basis/opengl/textures/textures.factor

@@ -11,14 +11,16 @@ IN: opengl.textures
 
 TUPLE: texture loc dim texture-coords texture display-list disposed ;
 
-<PRIVATE
-
 GENERIC: component-order>format ( component-order -- format type )
 
+M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
+M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
 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 ;
 
+<PRIVATE
+
 : repeat-last ( seq n -- seq' )
     over peek pad-tail concat ;
 

basis/ui/gadgets/glass/glass-docs.factor

@@ -0,0 +1,55 @@
+IN: ui.gadgets.glass
+USING: help.markup help.syntax ui.gadgets math.rectangles ;
+
+HELP: show-glass
+{ $values { "owner" gadget } { "child" gadget } { "visible-rect" rect } }
+{ $description "Displays " { $snippet "child" } " in the glass layer of the window containing " { $snippet "owner" } "."
+  $nl
+  "The child's position is calculated with a heuristic:"
+  { $list
+    "The child must fit inside the window"
+    { "The child must not obscure " { $snippet "visible-rect" } ", which is a rectangle whose origin is relative to " { $snippet "owner" } }
+    { "The child must otherwise be as close as possible to the edges of " { $snippet "visible-rect" } }
+  }
+  "For example, when displaying a menu, " { $snippet "visible-rect" } " is a single point at the mouse location, and when displaying a completion popup, " { $snippet "visible-rect" } " contains the bounds of the text element being completed."
+} ;
+
+HELP: hide-glass
+{ $values { "child" gadget } }
+{ $description "Hides a gadget displayed in a glass layer." } ;
+
+HELP: hide-glass-hook
+{ $values { "gadget" gadget } }
+{ $description "Called when a gadget displayed in a glass layer is hidden. The gadget can perform cleanup tasks here." } ;
+
+HELP: pass-to-popup
+{ $values { "gesture" "a gesture" } { "owner" "the popup's owner" } { "?" "a boolean" } }
+{ $description "Resends the gesture to the popup displayed by " { $snippet "owner" } ". The owner must have a " { $slot "popup" } " slot. Outputs " { $link f } " if the gesture was handled, " { $link t } " otherwise." } ;
+
+HELP: show-popup
+{ $values { "owner" gadget } { "popup" gadget } { "visible-rect" rect } }
+{ $description "Displays " { $snippet "popup" } " in the glass layer of the window containing " { $snippet "owner" } " as a popup."
+  $nl
+  "This word differs from " { $link show-glass } " in two respects:"
+  { $list
+    { "The popup is stored in the owner's " { $slot "popup" } " slot; the owner can call " { $link pass-to-popup } " to pass keyboard gestures to the popup" }
+    { "Pressing " { $snippet "ESC" } " with the popup visible will hide it" }
+  }
+} ;
+
+ARTICLE: "ui.gadgets.glass" "Glass layers"
+"The " { $vocab-link "ui.gadgets.glass" } " vocabulary implements support for displaying gadgets in the glass layer of a window. The gadget can be positioned arbitrarily within the glass layer, and while it is visible, mouse clicks outside of the glass layer are intercepted to hide the glass layer. Multiple glass layers can be active at a time; they behave as if stacked on top of each other."
+$nl
+"This feature is used for completion popups and " { $link "ui.gadgets.menus" } " in the " { $link "ui-tools" } "."
+$nl
+"Displaying a gadget in a glass layer:"
+{ $subsection show-glass }
+"Hiding a gadget in a glass layer:"
+{ $subsection hide-glass }
+"Callback generic invoked on the gadget when its glass layer is hidden:"
+{ $subsection hide-glass-hook }
+"Popup gadgets add support for forwarding keyboard gestures from an owner gadget to the glass layer:"
+{ $subsection show-popup }
+{ $subsection pass-to-popup } ;
+
+ABOUT: "ui.gadgets.glass"

basis/ui/gadgets/glass/glass.factor

@@ -71,7 +71,7 @@ popup H{
     { T{ key-down f f "ESC" } [ hide-glass ] }
 } set-gestures
 
-: pass-to-popup ( gesture interactor -- ? )
+: pass-to-popup ( gesture owner -- ? )
     popup>> focusable-child resend-gesture ;
 
 : show-popup ( owner popup visible-rect -- )

basis/ui/gadgets/menus/menus-docs.factor

@@ -16,7 +16,7 @@ HELP: show-commands-menu
 { $notes "Useful for right-click context menus." } ;
 
 ARTICLE: "ui.gadgets.menus" "Popup menus"
-"The " { $vocab-link "ui.gadgets.menus" } " vocabulary implements popup menus."
+"The " { $vocab-link "ui.gadgets.menus" } " vocabulary displays popup menus in " { $link "ui.gadgets.glass" } "."
 { $subsection <commands-menu> }
 { $subsection show-menu }
 { $subsection show-commands-menu } ;

basis/ui/gadgets/status-bar/status-bar-docs.factor

@@ -3,7 +3,7 @@ ui.gadgets ui.gadgets.worlds ui ;
 IN: ui.gadgets.status-bar
 
 HELP: show-status
-{ $values { "string" string } { "gadget" gadget } }
+{ $values { "string/f" string } { "gadget" gadget } }
 { $description "Displays a status message in the gadget's world." }
 { $notes "The status message will only be visible if the window was opened with " { $link open-status-window } ", and not " { $link open-window } "." } ;
 

basis/ui/pens/gradient/gradient.factor

@@ -41,4 +41,6 @@ M: gradient draw-interior
         [ last-vertices>> gl-vertex-pointer ]
         [ last-colors>> gl-color-pointer ]
         [ colors>> draw-gradient ]
-    } cleave ;
+    } cleave ;
+
+M: gradient pen-background 2drop transparent ;

basis/ui/pens/solid/solid.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors opengl ui.pens ui.pens.caching ;
+USING: kernel accessors opengl math colors ui.pens ui.pens.caching ;
 IN: ui.pens.solid
 
 TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
@@ -29,4 +29,4 @@ M: solid draw-boundary
     (gl-rect) ;
 
 M: solid pen-background
-    nip color>> ;
+    nip color>> dup alpha>> 1 number= [ drop transparent ] unless ;

basis/ui/ui-docs.factor

@@ -171,6 +171,7 @@ ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
 { $subsection "ui-frame-layout" }
 { $subsection "ui-book-layout" }
 "Advanced topics:"
+{ $subsection "ui.gadgets.glass" }
 { $subsection "ui-null-layout" }
 { $subsection "ui-incremental-layout" }
 { $subsection "ui-layout-impl" }

extra/cap/cap.factor

@@ -1,30 +1,31 @@
 ! Copyright (C) 2008 Doug Coleman, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui images.bitmap images.viewer
+opengl.gl sequences math.vectors ui images images.viewer
 models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 IN: cap
 
 : screenshot-array ( world -- byte-array )
-    dim>> [ first 3 * 4 align ] [ second ] bi * <byte-array> ;
+    dim>> [ first 4 * ] [ second ] bi * <byte-array> ;
 
 : gl-screenshot ( gadget -- byte-array )
     [
-        GL_BACK glReadBuffer
+        [
-        GL_PACK_ALIGNMENT 4 glPixelStorei
+            GL_BACK glReadBuffer
-        0 0
+            GL_PACK_ALIGNMENT 4 glPixelStorei
-    ] dip
+            0 0
-    [ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
+        ] dip
+        dim>> first2 GL_RGBA GL_UNSIGNED_BYTE
+    ]
     [ screenshot-array ] bi
     [ glReadPixels ] keep ;
 
 : screenshot ( window -- bitmap )
-    [ gl-screenshot ]
+    [ <image> ] dip
-    [ dim>> first2 ] bi
+    [ gl-screenshot >>bitmap ] [ dim>> >>dim ] bi
-    bgr>bitmap ;
+    RGBA >>component-order
-
+    t >>upside-down?
-: save-screenshot ( window path -- )
+    normalize-image ;
-    [ screenshot ] dip save-bitmap ;
 
 : screenshot. ( window -- )
     [ screenshot <image-gadget> ] [ title>> ] bi open-window ; 

extra/images/viewer/viewer.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images images.loader io.pathnames kernel
+USING: accessors images images.loader io.pathnames kernel namespaces
-namespaces opengl opengl.gl sequences strings ui ui.gadgets
+opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
 ui.gadgets.panes ui.render ;
 IN: images.viewer
 
@@ -12,8 +12,8 @@ M: image-gadget pref-dim*
 
 : draw-image ( image -- )
     0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
-    [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
+    [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
-    [ bitmap>> ] bi glDrawPixels ;
+    glDrawPixels ;
 
 M: image-gadget draw-gadget* ( gadget -- )
     image>> draw-image ;

extra/otug-talk/otug-talk.factor

@@ -1,41 +1,14 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: slides help.markup math arrays hashtables namespaces
+USING: slides help.markup math arrays hashtables namespaces sequences
-sequences kernel sequences parser memoize io.encodings.binary
+kernel sequences parser memoize io.encodings.binary locals
-locals kernel.private tools.vocabs.browser assocs quotations
+kernel.private tools.vocabs.browser assocs quotations tools.vocabs
- tools.vocabs tools.annotations tools.crossref
+tools.annotations tools.crossref help.topics math.functions
-help.topics math.functions compiler.tree.optimizer
+compiler.tree.optimizer compiler.cfg.optimizer fry ui.gadgets.panes
-compiler.cfg.optimizer fry
+tetris tetris.game combinators generalizations multiline
-ui.gadgets.panes tetris tetris.game combinators generalizations
+sequences.private ;
-multiline sequences.private ;
 IN: otug-talk
 
-USING: cairo cairo.ffi cairo.gadgets accessors
-io.backend ui.gadgets ;
-
-TUPLE: png-gadget < cairo-gadget surface ;
-
-: <png-gadget> ( file -- gadget )
-    png-gadget new-gadget
-    swap normalize-path
-    cairo_image_surface_create_from_png >>surface ; inline
-
-M: png-gadget pref-dim* ( gadget -- )
-    surface>>
-    [ cairo_image_surface_get_width ]
-    [ cairo_image_surface_get_height ]
-    bi 2array ;
-
-M: png-gadget render-cairo* ( gadget -- )
-    cr swap surface>> 0 0 cairo_set_source_surface
-    cr cairo_paint ;
-
-M: png-gadget ungraft* ( gadget -- )
-    surface>> cairo_surface_destroy ;
-
-: $bitmap ( element -- )
-    [ first <png-gadget> gadget. ] ($block) ;
-
 : $tetris ( element -- )
     drop [ <default-tetris> <tetris-gadget> gadget. ] ($block) ;
 
@@ -105,11 +78,11 @@ CONSTANT: otug-slides
     }
     { $slide "Data flow combinators - cleave family"
         { { $link bi } ", " { $link tri } ", " { $link cleave } }
-        { $bitmap "resource:extra/otug-talk/bi.png" }
+        { $image "resource:extra/otug-talk/bi.tiff" }
     }
     { $slide "Data flow combinators - cleave family"
         { { $link 2bi } ", " { $link 2tri } ", " { $link 2cleave } }
-        { $bitmap "resource:extra/otug-talk/2bi.png" }
+        { $image "resource:extra/otug-talk/2bi.tiff" }
     }
     { $slide "Data flow combinators"
         "First, let's define a data type:"
@@ -128,19 +101,19 @@ CONSTANT: otug-slides
     }
     { $slide "Data flow combinators - spread family"
         { { $link bi* } ", " { $link tri* } ", " { $link spread } }
-        { $bitmap "resource:extra/otug-talk/bi_star.png" }
+        { $image "resource:extra/otug-talk/bi_star.tiff" }
     }
     { $slide "Data flow combinators - spread family"
         { { $link 2bi* } }
-        { $bitmap "resource:extra/otug-talk/2bi_star.png" }
+        { $image "resource:extra/otug-talk/2bi_star.tiff" }
     }
     { $slide "Data flow combinators - apply family"
         { { $link bi@ } ", " { $link tri@ } ", " { $link napply } }
-        { $bitmap "resource:extra/otug-talk/bi_at.png" }
+        { $image "resource:extra/otug-talk/bi_at.tiff" }
     }
     { $slide "Data flow combinators - apply family"
         { { $link 2bi@ } }
-        { $bitmap "resource:extra/otug-talk/2bi_at.png" }
+        { $image "resource:extra/otug-talk/2bi_at.tiff" }
     }
     { $slide "Shuffle words"
         "When data flow combinators are not enough"

extra/slides/slides.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables help.markup help.stylesheet io
 io.styles kernel math models namespaces sequences ui ui.gadgets
-ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient ui.render
+ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient
 parser accessors colors ;
 IN: slides
 
@@ -98,6 +98,7 @@ TUPLE: slides < book ;
     parse-definition strip-tease [ parsed ] each ; parsing
 
 \ slides H{
+    { T{ button-down } [ request-focus ] }
     { T{ key-down f f "DOWN" } [ next-page ] }
     { T{ key-down f f "UP" } [ prev-page ] }
 } set-gestures

extra/tetris/gl/gl.factor

@@ -35,7 +35,7 @@ IN: tetris.gl
 : scale-board ( width height board -- )
     [ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
 
-: (draw-tetris) ( width height tetris -- )
+: draw-tetris ( width height tetris -- )
     #! width and height are in pixels
     GL_MODELVIEW [
         {
@@ -44,7 +44,4 @@ IN: tetris.gl
             [ next-piece draw-next-piece ]
             [ current-piece draw-piece ]
         } cleave
-    ] do-matrix ;
+    ] do-matrix ;
-
-: draw-tetris ( width height tetris -- )
-    origin get [ (draw-tetris) ] with-translation ;