Update accessors from
ui.gadgets.{grid-lines,grids,incremental,labelled,labels,lists,panes}db4
parent
7a75d2e070
commit
daee534587
|
@ -3,4 +3,4 @@ ui.render ;
|
|||
IN: ui.gadgets.grid-lines
|
||||
|
||||
HELP: grid-lines
|
||||
{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;
|
||||
{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $snippet "color" } " slot." } ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces opengl opengl.gl sequences
|
||||
USING: kernel accessors math namespaces opengl opengl.gl sequences
|
||||
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
|
||||
IN: ui.gadgets.grid-lines
|
||||
|
||||
|
@ -10,7 +10,7 @@ C: <grid-lines> grid-lines
|
|||
|
||||
SYMBOL: grid-dim
|
||||
|
||||
: half-gap grid get grid-gap [ 2/ ] map ; inline
|
||||
: half-gap grid get gap>> [ 2/ ] map ; inline
|
||||
|
||||
: grid-line-from/to ( orientation point -- from to )
|
||||
half-gap v-
|
||||
|
@ -25,7 +25,7 @@ SYMBOL: grid-dim
|
|||
M: grid-lines draw-boundary
|
||||
origin get [
|
||||
-0.5 -0.5 0.0 glTranslated
|
||||
grid-lines-color set-color [
|
||||
color>> set-color [
|
||||
dup grid set
|
||||
dup rect-dim half-gap v- grid-dim set
|
||||
compute-grid
|
||||
|
|
|
@ -14,9 +14,9 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
|
|||
HELP: grid
|
||||
{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
|
||||
$nl
|
||||
"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
|
||||
"The " { $snippet "gap" } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
|
||||
$nl
|
||||
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
|
||||
"The " { $snippet "fill?" } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
|
||||
$nl
|
||||
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
|
||||
$nl
|
||||
|
|
|
@ -48,7 +48,7 @@ grid
|
|||
dupd add-gaps dim-sum v+ ;
|
||||
|
||||
M: grid pref-dim*
|
||||
dup grid-gap swap compute-grid >r over r>
|
||||
dup gap>> swap compute-grid >r over r>
|
||||
gap-sum >r gap-sum r> (pair-up) ;
|
||||
|
||||
: do-grid ( dims grid quot -- )
|
||||
|
@ -57,7 +57,7 @@ M: grid pref-dim*
|
|||
drop ; inline
|
||||
|
||||
: grid-positions ( grid dims -- locs )
|
||||
>r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ;
|
||||
>r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ;
|
||||
|
||||
: position-grid ( grid horiz vert -- )
|
||||
pick >r
|
||||
|
@ -65,7 +65,7 @@ M: grid pref-dim*
|
|||
pair-up r> [ set-rect-loc ] do-grid ;
|
||||
|
||||
: resize-grid ( grid horiz vert -- )
|
||||
pick grid-fill? [
|
||||
pick fill?>> [
|
||||
pair-up swap [ (>>dim) ] do-grid
|
||||
] [
|
||||
2drop grid>> [ [ prefer ] each ] each
|
||||
|
|
|
@ -24,20 +24,20 @@ TUPLE: incremental < pack cursor ;
|
|||
|
||||
M: incremental pref-dim*
|
||||
dup layout-state>> [
|
||||
dup call-next-method over set-incremental-cursor
|
||||
] when incremental-cursor ;
|
||||
dup call-next-method over (>>cursor)
|
||||
] when cursor>> ;
|
||||
|
||||
: next-cursor ( gadget incremental -- cursor )
|
||||
[
|
||||
swap rect-dim swap incremental-cursor
|
||||
swap rect-dim swap cursor>>
|
||||
2dup v+ >r vmax r>
|
||||
] keep orientation>> set-axis ;
|
||||
|
||||
: update-cursor ( gadget incremental -- )
|
||||
[ next-cursor ] keep set-incremental-cursor ;
|
||||
[ next-cursor ] keep (>>cursor) ;
|
||||
|
||||
: incremental-loc ( gadget incremental -- )
|
||||
dup incremental-cursor swap orientation>> v*
|
||||
dup cursor>> swap orientation>> v*
|
||||
swap set-rect-loc ;
|
||||
|
||||
: prefer-incremental ( gadget -- )
|
||||
|
@ -57,5 +57,5 @@ M: incremental pref-dim*
|
|||
not-in-layout
|
||||
dup (clear-gadget)
|
||||
dup forget-pref-dim
|
||||
{ 0 0 } over set-incremental-cursor
|
||||
{ 0 0 } over (>>cursor)
|
||||
parent>> [ relayout ] when* ;
|
||||
|
|
|
@ -16,7 +16,7 @@ TUPLE: labelled-gadget < track content ;
|
|||
swap >>content
|
||||
dup content>> 1 track-add ;
|
||||
|
||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||
M: labelled-gadget focusable-child* content>> ;
|
||||
|
||||
: <labelled-scroller> ( gadget title -- gadget )
|
||||
>r <scroller> r> <labelled-gadget> ;
|
||||
|
@ -53,4 +53,4 @@ TUPLE: closable-gadget < frame content ;
|
|||
swap >>content
|
||||
dup content>> @center grid-add ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
M: closable-gadget focusable-child* content>> ;
|
||||
|
|
|
@ -14,9 +14,9 @@ TUPLE: label < gadget text font color ;
|
|||
|
||||
: set-label-string ( string label -- )
|
||||
CHAR: \n pick memq? [
|
||||
>r string-lines r> set-label-text
|
||||
>r string-lines r> (>>text)
|
||||
] [
|
||||
set-label-text
|
||||
(>>text)
|
||||
] if ; inline
|
||||
|
||||
: label-theme ( gadget -- gadget )
|
||||
|
|
|
@ -27,8 +27,8 @@ TUPLE: list < pack index presenter color hook ;
|
|||
control-value length 1- min 0 max ;
|
||||
|
||||
: bound-index ( list -- )
|
||||
dup list-index over calc-bounded-index
|
||||
swap set-list-index ;
|
||||
dup index>> over calc-bounded-index
|
||||
swap (>>index) ;
|
||||
|
||||
: list-presentation-hook ( list -- quot )
|
||||
hook>> [ [ list? ] find-parent ] prepend ;
|
||||
|
@ -53,18 +53,18 @@ M: list model-changed
|
|||
bound-index ;
|
||||
|
||||
: selected-rect ( list -- rect )
|
||||
dup list-index swap children>> ?nth ;
|
||||
dup index>> swap children>> ?nth ;
|
||||
|
||||
M: list draw-gadget*
|
||||
origin get [
|
||||
dup list-color set-color
|
||||
dup color>> set-color
|
||||
selected-rect [ rect-extent gl-fill-rect ] when*
|
||||
] with-translation ;
|
||||
|
||||
M: list focusable-child* drop t ;
|
||||
|
||||
: list-value ( list -- object )
|
||||
dup list-index swap control-value ?nth ;
|
||||
dup index>> swap control-value ?nth ;
|
||||
|
||||
: scroll>selected ( list -- )
|
||||
#! We change the rectangle's width to zero to avoid
|
||||
|
@ -79,22 +79,22 @@ M: list focusable-child* drop t ;
|
|||
2drop
|
||||
] [
|
||||
[ control-value length rem ] keep
|
||||
[ set-list-index ] keep
|
||||
[ (>>index) ] keep
|
||||
[ relayout-1 ] keep
|
||||
scroll>selected
|
||||
] if ;
|
||||
|
||||
: select-previous ( list -- )
|
||||
dup list-index 1- swap select-index ;
|
||||
dup index>> 1- swap select-index ;
|
||||
|
||||
: select-next ( list -- )
|
||||
dup list-index 1+ swap select-index ;
|
||||
dup index>> 1+ swap select-index ;
|
||||
|
||||
: invoke-value-action ( list -- )
|
||||
dup list-empty? [
|
||||
dup list-hook call
|
||||
dup hook>> call
|
||||
] [
|
||||
dup list-index swap nth-gadget invoke-secondary
|
||||
dup index>> swap nth-gadget invoke-secondary
|
||||
] if ;
|
||||
|
||||
: select-gadget ( gadget list -- )
|
||||
|
|
|
@ -173,7 +173,7 @@ M: pane-stream make-span-stream
|
|||
>r pick at r> when* ; inline
|
||||
|
||||
: apply-foreground-style ( style gadget -- style gadget )
|
||||
foreground [ over set-label-color ] apply-style ;
|
||||
foreground [ over (>>color) ] apply-style ;
|
||||
|
||||
: apply-background-style ( style gadget -- style gadget )
|
||||
background [ solid-interior ] apply-style ;
|
||||
|
@ -184,7 +184,7 @@ M: pane-stream make-span-stream
|
|||
font-size swap at 12 or 3array ;
|
||||
|
||||
: apply-font-style ( style gadget -- style gadget )
|
||||
over specified-font over set-label-font ;
|
||||
over specified-font over (>>font) ;
|
||||
|
||||
: apply-presentation-style ( style gadget -- style gadget )
|
||||
presented [ <presentation> ] apply-style ;
|
||||
|
@ -255,7 +255,7 @@ M: pane-stream make-block-stream
|
|||
|
||||
! Tables
|
||||
: apply-table-gap-style ( style grid -- style grid )
|
||||
table-gap [ over set-grid-gap ] apply-style ;
|
||||
table-gap [ over (>>gap) ] apply-style ;
|
||||
|
||||
: apply-table-border-style ( style grid -- style grid )
|
||||
table-border [ <grid-lines> over (>>boundary) ]
|
||||
|
@ -263,7 +263,7 @@ M: pane-stream make-block-stream
|
|||
|
||||
: styled-grid ( style grid -- grid )
|
||||
<grid>
|
||||
f over set-grid-fill?
|
||||
f over (>>fill?)
|
||||
apply-table-gap-style
|
||||
apply-table-border-style
|
||||
nip ;
|
||||
|
|
Loading…
Reference in New Issue