Fancy new buttons
parent
07ea40eaf6
commit
09630e5bf4
|
@ -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>
|
||||
|
|
|
@ -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>> % ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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* ? ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 )
|
||||
|
||||
|
|
|
@ -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>> ;
|
|
@ -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>> ;
|
|
@ -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
|
Loading…
Reference in New Issue