Fancy new buttons

db4
Slava Pestov 2009-02-14 21:53:39 -06:00
parent 07ea40eaf6
commit 09630e5bf4
9 changed files with 124 additions and 40 deletions

View File

@ -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>

View File

@ -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>> % ;

View File

@ -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 )

View File

@ -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* ? ;

View File

@ -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"

View File

@ -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 )

View File

@ -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) ;
(gl-rect) ;
M: solid pen-background
nip color>> ;

View File

@ -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* ;
[ render-tile ] curry tri-curry@ tri-curry* tri* ;
M: tile-pen pen-background nip background>> ;
M: tile-pen pen-foreground nip foreground>> ;

View File

@ -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