Merge remote-tracking branch 'origin/master' into modern-harvey2

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

@@ -1,19 +1,28 @@
 USING: ui.gadgets help.markup help.syntax strings models
-ui.gadgets.panes ;
+ui.gadgets.panes ui.theme ;
 IN: ui.gadgets.labeled
 
 HELP: labeled-gadget
 { $class-description "A labeled gadget can be created by calling " { $link <labeled-gadget> } "." } ;
 
 HELP: <labeled-gadget>
-{ $values { "gadget" gadget } { "title" string } { "color" "a color" } { "labeled" "a new " { $link <labeled-gadget> } } }
+{ $values { "content" gadget } { "title" string } { "labeled" labeled-gadget } }
-{ $description "Creates a new " { $link labeled-gadget } " display " { $snippet "gadget" } " with " { $snippet "title" } " on top." } ;
+{ $description "Creates a new " { $link labeled-gadget } " displaying " { $snippet "content" } " with " { $snippet "title" } " on top." } ;
+
+HELP: <colored-labeled-gadget>
+{ $values { "content" gadget } { "title" string } { "color" "a color" } { "labeled" labeled-gadget } }
+{ $description "Creates a new " { $link labeled-gadget } " displaying " { $snippet "content" } " with " { $snippet "title" } " on top, adding a " { $snippet "color" } " colored divider between title bar and content." } ;
+
+HELP: <framed-labeled-gadget>
+{ $values { "content" gadget } { "title" string } { "color" "a color" } { "labeled" labeled-gadget } }
+{ $description "Creates a new " { $link labeled-gadget } " displaying " { $snippet "content" } " with " { $snippet "title" } " on top, adding a " { $snippet "color" } " colored divider between title bar and content and a " { $link labeled-border-color } " frame." } ;
 
 ARTICLE: "ui.gadgets.labeled" "Labeled gadgets"
 "The " { $vocab-link "ui.gadgets.labeled" } " vocabulary implements labeled borders around child gadgets."
 { $subsections
     labeled-gadget
     <labeled-gadget>
+    <colored-labeled-gadget>
     <framed-labeled-gadget>
 } ;
 

basis/ui/gadgets/labeled/labeled-tests.factor

@@ -3,6 +3,5 @@ ui.gadgets ui.gadgets.labeled ;
 IN: ui.gadgets.labeled.tests
 
 { t } [
-    <gadget> "Hey" color: blue <labeled-gadget>
+    <gadget> "Hey" <labeled-gadget> content>> gadget?
-    content>> gadget?
 ] unit-test

basis/ui/gadgets/labeled/labeled.factor

@@ -5,7 +5,7 @@ ui.gadgets.labels ui.gadgets.packs ui.gadgets.tracks
 ui.pens.gradient ui.pens.solid ui.theme ;
 IN: ui.gadgets.labeled
 
-TUPLE: labeled-gadget < track content color ;
+TUPLE: labeled-gadget < track content ;
 
 <PRIVATE
 
@@ -18,36 +18,19 @@ M: labeled-gadget focusable-child* content>> ;
     [ title-bar-gradient <gradient> ]
     if ;
 
-: add-title-bar ( title track -- track )
+: <title-bar> ( title -- title-bar )
-    swap >label
+    >label [ t >>bold? ] change-font
-    [ t >>bold? ] change-font
+    { 0 4 } <border> title-bar-interior >>interior ;
-    { 0 4 } <border>
-    title-bar-interior >>interior
-    f track-add ;
-
-: add-content ( content track -- track )
-    swap 1 track-add ;
-
-: add-color-line ( color track -- track )
-    <shelf> { 0 1.5 } <border>
-    rot <solid> >>interior
-    f track-add ;
-
-: add-content-area ( labeled -- labeled )
-    [ ] [ content>> ] [ color>> ] tri
-    vertical <track>
-    add-color-line
-    add-content
-    1 track-add ;
 
 PRIVATE>
 
-: <labeled-gadget> ( gadget title color -- labeled )
+: <labeled-gadget> ( content title -- labeled )
     vertical labeled-gadget new-track
-    swap >>color
+        swap <title-bar> f track-add
-    add-title-bar
+        swap [ >>content ] [ 1 track-add ] bi ;
-    swap >>content
-    add-content-area ;
 
-: <framed-labeled-gadget> ( gadget title color -- labeled )
+: <colored-labeled-gadget> ( content title color -- labeled )
-    <labeled-gadget> labeled-border-color <solid> >>boundary ;
+    [ <labeled-gadget> ] dip <solid> >>interior { 0 3 } >>gap ;
+
+: <framed-labeled-gadget> ( content title color -- labeled )
+    <colored-labeled-gadget> labeled-border-color <solid> >>boundary ;

basis/ui/pens/caching/caching-tests.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors.constants kernel tools.test
+USING: accessors alien.c-types colors.constants kernel
-ui.gadgets.labels ui.pens.caching ui.pens.gradient ;
+specialized-arrays tools.test ui.gadgets.labels
+ui.pens.caching ui.pens.gradient ;
 IN: ui.pens.caching.tests
 
 SPECIALIZED-ARRAY: float

basis/ui/tools/error-list/error-list.factor

@@ -168,11 +168,11 @@ error-display "toolbar" f {
     error-list vertical <track> with-lines
         error-list <error-list-toolbar> f track-add
         error-list source-file-table>> margins <scroller> white-interior
-        "Source files" source-files-color <labeled-gadget> 1/4 track-add
+        "Source files" source-files-color <colored-labeled-gadget> 1/4 track-add
         error-list error-table>> margins <scroller> white-interior
-        "Errors" errors-color <labeled-gadget> 1/4 track-add
+        "Errors" errors-color <colored-labeled-gadget> 1/4 track-add
         error-list error-display>>
-        "Details" details-color <labeled-gadget> 1/2 track-add
+        "Details" details-color <colored-labeled-gadget> 1/2 track-add
     1 track-add ;
 
 M: error-list-gadget focusable-child*

basis/ui/tools/inspector/inspector.factor

@@ -101,9 +101,9 @@ M: inspector-table compute-column-widths
         swap >>model
         dup model>> <inspector-table> >>table
         dup model>> <summary-gadget> margins white-interior
-        "Object" object-color <labeled-gadget> f track-add
+        "Object" object-color <colored-labeled-gadget> f track-add
         dup table>> <scroller> margins white-interior
-        "Contents" contents-color <labeled-gadget> 1 track-add ;
+        "Contents" contents-color <colored-labeled-gadget> 1 track-add ;
 
 M: inspector-gadget focusable-child*
     table>> ;

basis/ui/tools/traceback/traceback.factor

@@ -33,12 +33,12 @@ M: stack-entry-renderer row-value drop object>> ;
 
 : <stack-display> ( model quot title color -- gadget )
     [ '[ dup _ when ] <arrow> <stack-table> margins <scroller> white-interior ] 2dip
-    <labeled-gadget> ;
+    <colored-labeled-gadget> ;
 
 : <callstack-display> ( model -- gadget )
     [ [ call>> callstack. ] when* ]
     <pane-control> t >>scrolls? margins <scroller> white-interior
-    "Call stack" call-stack-color <labeled-gadget> ;
+    "Call stack" call-stack-color <colored-labeled-gadget> ;
 
 : <datastack-display> ( model -- gadget )
     [ data>> ] "Data stack" data-stack-color <stack-display> ;

basis/windows/dragdrop-listener/dragdrop-listener.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008, 2009 Joe Groff, Slava Pestov.
 ! Copyright (C) 2017-2018 Alexander Ilin.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.accessors alien.data alien.strings
+USING: accessors alien.accessors alien.c-types alien.data
-classes.struct io.encodings.utf16n kernel make math namespaces
+alien.strings classes.struct io.encodings.utf16n kernel make
-prettyprint sequences specialized-arrays
+math namespaces prettyprint sequences specialized-arrays
 ui.backend.windows ui.gadgets.worlds ui.gestures
 ui.tools.listener windows.com windows.com.wrapper
 windows.dropfiles windows.kernel32 windows.ole32 windows.shell32

extra/gml/ui/ui.factor

@@ -27,7 +27,7 @@ M: stack-entry-renderer row-value
 
 : <stack-display> ( model -- gadget )
     <stack-table> <scroller> "Operand stack"
-    color: dark-gray <labeled-gadget> ;
+    color: dark-gray <colored-labeled-gadget> ;
 
 TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
 
@@ -99,7 +99,7 @@ CONSTANT: example-dir "vocab:gml/examples/"
         30 >>max-rows
         40 >>min-cols
         40 >>max-cols
-    <scroller> "Editor" color: dark-gray <labeled-gadget> ;
+    <scroller> "Editor" color: dark-gray <colored-labeled-gadget> ;
 
 : <gml-editor> ( -- gadget )
     2 3 gml-editor new-frame

extra/merger/merger.factor

@@ -19,8 +19,7 @@ MAIN-WINDOW: merger-window {
                     [ swap set-control-value ] 2bi
                 ] [ drop ] if*
             ] <border-button> swap >>model swap
-            color: black <labeled-gadget>
+            <labeled-gadget> 1 track-add
-            1 track-add
         ] 2each
     ] keep
     dup first2

extra/minesweeper/minesweeper.factor

@@ -29,9 +29,6 @@ TUPLE: cell #adjacent mined? state ;
 : cells-dim ( cells -- rows cols )
     [ length ] [ first length ] bi ;
 
-: unmined-cell ( cells -- cell )
-    f [ dup mined?>> ] [ drop dup random random ] do while nip ;
-
 : #mines ( cells -- n )
     [ [ mined?>> ] count ] map-sum ;
 
@@ -41,6 +38,9 @@ TUPLE: cell #adjacent mined? state ;
 : #mines-remaining ( cells -- n )
     [ #mines ] [ #flagged ] bi - ;
 
+: unmined-cell ( cells -- cell )
+    f [ dup mined?>> ] [ drop dup random random ] do while nip ;
+
 : place-mines ( cells n -- cells )
     [ dup unmined-cell t >>mined? drop ] times ;
 
@@ -81,7 +81,7 @@ DEFER: click-cell-at
     neighbors [
         first2 [ row + ] [ col + ] bi* :> ( row' col' )
         cells row' col' cell-at [
-            { [ mined?>> ] [ state>> +question+ = ] } 1|| [
+            { [ mined?>> ] [ state>> +flagged+ = ] } 1|| [
                 cells row' col' click-cell-at drop
             ] unless
         ] when*
@@ -229,7 +229,7 @@ M: grid-gadget draw-gadget*
         h 3 55 between?
         gadget pref-dim first 2/ w - abs 26 < and [
             gadget [ reset-cells ] change-cells
-            f >>start f >>end relayout-1
+            f >>start f >>end drop
         ] when
     ] [
         h 58 - w [ 32 /i ] bi@ :> ( row col )
@@ -238,10 +238,9 @@ M: grid-gadget draw-gadget*
             cells row col click-cell-at [
                 gadget start>> [ now gadget start<< ] unless
                 cells game-over? [ now gadget end<< ] when
-                gadget relayout-1
             ] when
         ] unless
-    ] if ;
+    ] if gadget relayout-1 ;
 
 :: on-mark ( gadget -- )
     gadget hand-rel first2 :> ( w h )
@@ -252,10 +251,9 @@ M: grid-gadget draw-gadget*
             cells row col mark-cell-at [
                 gadget start>> [ now gadget start<< ] unless
                 cells game-over? [ now gadget end<< ] when
-                gadget relayout-1
             ] when
         ] unless
-    ] when ;
+    ] when gadget relayout-1 ;
 
 : new-game ( gadget rows cols mines -- )
     [ make-cells ] dip place-mines update-counts >>cells