Fancy new buttons

basis/ui/gadgets/buttons/buttons.factor

@@ -6,11 +6,16 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
 ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks
 ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid
 ui.pens.image ui.pens.tile math.rectangles locals fry
-combinators.smart ;
+combinators.smart call ;
 IN: ui.gadgets.buttons
 
 TUPLE: button < border pressed? selected? quot ;
 
+<PRIVATE
+
+: find-button ( gadget -- button )
+    [ button? ] find-parent ;
+
 : buttons-down? ( -- ? )
     hand-buttons get-global empty? not ;
 
@@ -20,6 +25,8 @@ TUPLE: button < border pressed? selected? quot ;
 : mouse-clicked? ( gadget -- ? )
     hand-clicked get-global child? ;
 
+PRIVATE>
+
 : button-update ( button -- )
     dup
     [ mouse-clicked? ] [ button-rollover? ] bi and
@@ -27,10 +34,10 @@ TUPLE: button < border pressed? selected? quot ;
     >>pressed?
     relayout-1 ;
 
-: if-clicked ( button quot -- )
+: button-clicked ( button -- )
-    [ dup button-update dup button-rollover? ] dip [ drop ] if ;
+    dup button-update
-
+    dup button-rollover?
-: button-clicked ( button -- ) dup quot>> if-clicked ;
+    [ dup quot>> call( button -- ) ] [ drop ] if ;
 
 button H{
     { T{ button-up } [ button-clicked ] }
@@ -51,9 +58,6 @@ pressed selected pressed-selected ;
 
 C: <button-pen> button-pen
 
-: find-button ( gadget -- button )
-    [ button? ] find-parent ;
-
 : button-pen ( button pen -- button pen )
     over find-button {
         { [ dup [ pressed?>> ] [ selected?>> ] bi and ] [ drop pressed-selected>> ] }
@@ -79,23 +83,57 @@ M: button-pen pen-pref-dim
         } 2cleave
     ] [ vmax ] reduce-outputs ;
 
+M: button-pen pen-background
+    button-pen pen-background ;
+
+M: button-pen pen-foreground
+    button-pen pen-foreground ;
+
+<PRIVATE
+
 : align-left ( button -- button )
     { 0 1/2 } >>align ; inline
 
 : roll-button-theme ( button -- button )
     f COLOR: black <solid> dup f f <button-pen> >>boundary
-    f f COLOR: black <solid> f f <button-pen> >>interior
+    f f COLOR: dark-gray <solid> f f <button-pen> >>interior
     align-left ; inline
 
+PRIVATE>
+
 : <roll-button> ( label quot -- button )
     <button> roll-button-theme ;
 
-: <border-button-pen> ( -- pen )
+<PRIVATE
-    "button" "button-clicked"
+
+: <border-button-state-pen> ( prefix background foreground -- pen )
     [
         "-left" "-middle" "-right"
-        [ append theme-image ] tri-curry@ tri <tile-pen> dup
+        [ append theme-image ] tri-curry@ tri
-    ] bi@ dup <button-pen> ;
+    ] 2dip <tile-pen> ;
+
+CONSTANT: button-background
+    T{ rgba
+         f
+         0.8901960784313725
+         0.8862745098039215
+         0.8588235294117647
+         1.0
+    }
+
+CONSTANT: button-clicked-background
+    T{ rgba
+         f
+         0.2156862745098039
+         0.2431372549019608
+         0.2823529411764706
+         1.0
+    }
+    
+: <border-button-pen> ( -- pen )
+    "button" button-background COLOR: black <border-button-state-pen> dup
+    "button-clicked" button-clicked-background COLOR: white <border-button-state-pen> dup dup
+    <button-pen> ;
 
 : border-button-theme ( gadget -- gadget )
     horizontal >>orientation
@@ -103,6 +141,8 @@ M: button-pen pen-pref-dim
     dup dup interior>> pen-pref-dim >>min-dim
     { 10 0 } >>size ; inline
 
+PRIVATE>
+
 : <border-button> ( label quot -- button )
     <button> border-button-theme ;
 
@@ -119,7 +159,9 @@ repeat-button H{
     #! the mouse is held down.
     repeat-button new-button border-button-theme ;
 
-: <checkmark-paint> ( -- pen )
+<PRIVATE
+
+: <checkmark-pen> ( -- pen )
     "checkbox" theme-image <image-pen>
     "checkbox" theme-image <image-pen>
     "checkbox-clicked" theme-image <image-pen>
@@ -129,12 +171,14 @@ repeat-button H{
 
 : <checkmark> ( -- gadget )
     <gadget>
-    <checkmark-paint> >>interior
+    <checkmark-pen> >>interior
     dup dup interior>> pen-pref-dim >>dim ;
 
 : toggle-model ( model -- )
     [ not ] change-model ;
 
+PRIVATE>
+
 TUPLE: checkbox < button ;
 
 : <checkbox> ( model label -- checkbox )
@@ -147,7 +191,9 @@ TUPLE: checkbox < button ;
 M: checkbox model-changed
     swap value>> >>selected? relayout-1 ;
 
-: <radio-paint> ( -- pen )
+<PRIVATE
+
+: <radio-pen> ( -- pen )
     "radio" theme-image <image-pen>
     "radio" theme-image <image-pen>
     "radio-clicked" theme-image <image-pen>
@@ -157,7 +203,7 @@ M: checkbox model-changed
 
 : <radio-knob> ( -- gadget )
     <gadget>
-    <radio-paint> >>interior
+    <radio-pen> >>interior
     dup dup interior>> pen-pref-dim >>dim ;
 
 TUPLE: radio-control < button value ;
@@ -175,6 +221,8 @@ M: radio-control model-changed
 :: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent )
     assoc model [ parent swap quot call add-gadget ] assoc-each ; inline
 
+PRIVATE>
+
 : <radio-button> ( value model label -- gadget )
     <radio-knob> label-on-right <radio-control> ;
 
@@ -190,11 +238,8 @@ M: radio-control model-changed
     <shelf>
         [ <toggle-button> ] <radio-controls> ;
 
-: command-button-quot ( target command -- quot )
-    '[ _ _ invoke-command drop ] ;
-
 : <command-button> ( target gesture command -- button )
-    [ command-string swap ] keep command-button-quot <border-button> ;
+    [ command-string swap ] keep '[ _ _ invoke-command drop ] <border-button> ;
 
 : <toolbar> ( target -- toolbar )
     <shelf>

basis/ui/gadgets/labels/labels.factor

@@ -55,7 +55,13 @@ M: label baseline
     >label< dup string? [ first ] unless
     line-metrics ascent>> round ;
 
-M: label draw-gadget* >label< draw-text ;
+M: label draw-gadget*
+    >label<
+    [
+        background get [ font-with-background ] when*
+        foreground get [ font-with-foreground ] when*
+    ] dip
+    draw-text ;
 
 M: label gadget-text* string>> % ;
 

basis/ui/gadgets/panes/panes.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io kernel namespaces sequences io.styles
+USING: arrays hashtables io kernel namespaces sequences
 strings quotations math opengl combinators memoize math.vectors
 sorting splitting assocs classes.tuple models continuations
 destructors accessors math.rectangles fry fonts ui.pens.solid
@@ -9,7 +9,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
 ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
 ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
 ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks
-ui.gadgets.icons ui.gadgets.grid-lines colors call ;
+ui.gadgets.icons ui.gadgets.grid-lines colors call io.styles ;
 IN: ui.gadgets.panes
 
 TUPLE: pane < pack
@@ -266,9 +266,7 @@ M: pane-block-stream dispose
     unnest-pane-stream write-gadget ;
 
 M: pane-stream make-block-stream
-    [ pane-block-stream new-nested-pane-stream ]
+    pane-block-stream new-nested-pane-stream ;
-    [ drop page-color swap at* [ background associate ] when ]
-    2bi [ <style-stream> ] when* ;
 
 ! Tables
 : apply-table-gap-style ( style grid -- style grid )

basis/ui/gadgets/sliders/sliders.factor

@@ -205,7 +205,7 @@ TUPLE: slider-pen enabled disabled ;
             "vertical-scroller-bottom-disabled" theme-image
         ] }
     } case
-    [ <tile-pen> ] bi-curry@ 2bi \ slider-pen boa ;
+    [ f f <tile-pen> ] bi-curry@ 2bi \ slider-pen boa ;
 
 : slider-pen ( slider pen -- pen )
     [ slider-enabled? ] [ [ enabled>> ] [ disabled>> ] bi ] bi* ? ;

basis/ui/pens/pens-docs.factor

@@ -2,11 +2,11 @@ IN: ui.pens
 USING: help.markup help.syntax kernel ui.gadgets ;
 
 HELP: draw-interior
-{ $values { "interior" object } { "gadget" gadget } } 
+{ $values { "pen" object } { "gadget" gadget } } 
 { $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ;
 
 HELP: draw-boundary
-{ $values { "boundary" object } { "gadget" gadget } } 
+{ $values { "pen" object } { "gadget" gadget } } 
 { $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
 
 ARTICLE: "ui-pen-protocol" "UI pen protocol"

basis/ui/pens/pens.factor

@@ -3,9 +3,17 @@
 USING: kernel ;
 IN: ui.pens
 
-GENERIC: draw-interior ( gadget interior -- )
+GENERIC: draw-interior ( gadget pen -- )
 
-GENERIC: draw-boundary ( gadget boundary -- )
+GENERIC: draw-boundary ( gadget pen -- )
+
+GENERIC: pen-background ( gadget pen -- color )
+
+M: object pen-background 2drop f ;
+
+GENERIC: pen-foreground ( gadget pen -- color )
+
+M: object pen-foreground 2drop f ;
 
 GENERIC: pen-pref-dim ( gadget pen -- dim )
 

basis/ui/pens/solid/solid.factor

@@ -3,7 +3,6 @@
 USING: kernel accessors opengl ui.pens ui.pens.caching ;
 IN: ui.pens.solid
 
-! Solid fill/border
 TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
 
 : <solid> ( color -- solid ) solid new swap >>color ;
@@ -16,7 +15,6 @@ M: solid recompute-pen
 
 <PRIVATE
 
-! Solid pen
 : (solid) ( gadget pen -- )
     [ compute-pen ] [ color>> gl-color ] bi ;
 
@@ -29,3 +27,6 @@ M: solid draw-interior
 M: solid draw-boundary
     [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
     (gl-rect) ;
+
+M: solid pen-background
+    nip color>> ;

basis/ui/pens/tile/tile.factor

@@ -5,9 +5,9 @@ combinators ui.pens ;
 IN: ui.pens.tile
 
 ! Tile pen
-TUPLE: tile-pen left center right ;
+TUPLE: tile-pen left center right background foreground ;
 
-: <tile-pen> ( left center right -- pen )
+: <tile-pen> ( left center right background foreground -- pen )
     tile-pen boa ;
 
 : >tile-pen< ( pen -- left center right )
@@ -46,3 +46,7 @@ M: tile-pen draw-interior ( gadget pen -- )
         [ drop ]
     } 2cleave
     [ render-tile ] curry tri-curry@ tri-curry* tri* ;
+
+M: tile-pen pen-background nip background>> ;
+
+M: tile-pen pen-foreground nip foreground>> ;

basis/ui/render/render.factor

@@ -53,7 +53,7 @@ SYMBOL: origin
 
 : translate ( rect/point -- ) loc>> origin [ v+ ] change ;
 
-DEFER: draw-gadget
+GENERIC: draw-children ( gadget -- )
 
 : (draw-gadget) ( gadget -- )
     dup loc>> origin get v+ origin [
@@ -64,7 +64,7 @@ DEFER: draw-gadget
                 bi
             ] with-translation
         ]
-        [ visible-children [ draw-gadget ] each ]
+        [ draw-children ]
         [
             dup boundary>> dup [
                 origin get [ draw-boundary ] with-translation
@@ -88,6 +88,28 @@ DEFER: draw-gadget
         [ [ (draw-gadget) ] with-clipping ]
     } cond ;
 
+! For text rendering
+SYMBOL: background
+
+SYMBOL: foreground
+
+GENERIC: gadget-background ( gadget -- color )
+
+M: gadget gadget-background dup interior>> pen-background ;
+
+GENERIC: gadget-foreground ( gadget -- color )
+
+M: gadget gadget-foreground dup interior>> pen-foreground ;
+
+M: gadget draw-children
+    [ visible-children ]
+    [ gadget-background ]
+    [ gadget-foreground ] tri [
+        [ foreground set ] when*
+        [ background set ] when*
+        [ draw-gadget ] each
+    ] with-scope ;
+
 CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
 
 CONSTANT: focus-border-color COLOR: dark-gray