From 09630e5bf43e78f7fa1e19e9205036d41df1988b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Feb 2009 21:53:39 -0600
Subject: [PATCH] Fancy new buttons
---
basis/ui/gadgets/buttons/buttons.factor | 87 +++++++++++++++++++------
basis/ui/gadgets/labels/labels.factor | 8 ++-
basis/ui/gadgets/panes/panes.factor | 8 +--
basis/ui/gadgets/sliders/sliders.factor | 2 +-
basis/ui/pens/pens-docs.factor | 4 +-
basis/ui/pens/pens.factor | 12 +++-
basis/ui/pens/solid/solid.factor | 7 +-
basis/ui/pens/tile/tile.factor | 10 ++-
basis/ui/render/render.factor | 26 +++++++-
9 files changed, 124 insertions(+), 40 deletions(-)
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index 115854dcfd..5304565486 100644
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/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 -- )
- [ dup button-update dup button-rollover? ] dip [ drop ] if ;
-
-: button-clicked ( button -- ) dup quot>> if-clicked ;
+: button-clicked ( button -- )
+ dup button-update
+ dup button-rollover?
+ [ 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 )
- "button" "button-clicked"
+<PRIVATE
+
+: <border-button-state-pen> ( prefix background foreground -- pen )
[
"-left" "-middle" "-right"
- [ append theme-image ] tri-curry@ tri <tile-pen> dup
- ] bi@ dup <button-pen> ;
+ [ append theme-image ] tri-curry@ tri
+ ] 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>
diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor
index ae784b6983..7ac729c451 100644
--- a/basis/ui/gadgets/labels/labels.factor
+++ b/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>> % ;
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index 3842b9959f..e9f88f774a 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/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 ]
- [ drop page-color swap at* [ background associate ] when ]
- 2bi [ <style-stream> ] when* ;
+ pane-block-stream new-nested-pane-stream ;
! Tables
: apply-table-gap-style ( style grid -- style grid )
diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor
index 175d94473a..24607d3aef 100644
--- a/basis/ui/gadgets/sliders/sliders.factor
+++ b/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* ? ;
diff --git a/basis/ui/pens/pens-docs.factor b/basis/ui/pens/pens-docs.factor
index d12a0c8d1b..ebe41d213d 100644
--- a/basis/ui/pens/pens-docs.factor
+++ b/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"
diff --git a/basis/ui/pens/pens.factor b/basis/ui/pens/pens.factor
index 01724f1d28..9a1717f534 100644
--- a/basis/ui/pens/pens.factor
+++ b/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 )
diff --git a/basis/ui/pens/solid/solid.factor b/basis/ui/pens/solid/solid.factor
index d8f839e4ca..32d400463e 100644
--- a/basis/ui/pens/solid/solid.factor
+++ b/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 ;
@@ -28,4 +26,7 @@ M: solid draw-interior
M: solid draw-boundary
[ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
- (gl-rect) ;
\ No newline at end of file
+ (gl-rect) ;
+
+M: solid pen-background
+ nip color>> ;
\ No newline at end of file
diff --git a/basis/ui/pens/tile/tile.factor b/basis/ui/pens/tile/tile.factor
index 2909aa426b..7f26e928aa 100644
--- a/basis/ui/pens/tile/tile.factor
+++ b/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 )
@@ -45,4 +45,8 @@ M: tile-pen draw-interior ( gadget pen -- )
[ compute-tile-widths ]
[ drop ]
} 2cleave
- [ render-tile ] curry tri-curry@ tri-curry* tri* ;
\ No newline at end of file
+ [ render-tile ] curry tri-curry@ tri-curry* tri* ;
+
+M: tile-pen pen-background nip background>> ;
+
+M: tile-pen pen-foreground nip foreground>> ;
\ No newline at end of file
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index edeba07d12..bd79563137 100755
--- a/basis/ui/render/render.factor
+++ b/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
\ No newline at end of file