Merge branch 'master' of git://factorcode.org/git/factor
commit
278d2457a7
|
@ -3,4 +3,4 @@ ui.render ;
|
||||||
IN: ui.gadgets.grid-lines
|
IN: ui.gadgets.grid-lines
|
||||||
|
|
||||||
HELP: 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.
|
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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 ;
|
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
|
||||||
IN: ui.gadgets.grid-lines
|
IN: ui.gadgets.grid-lines
|
||||||
|
|
||||||
|
@ -10,7 +10,7 @@ C: <grid-lines> grid-lines
|
||||||
|
|
||||||
SYMBOL: grid-dim
|
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 )
|
: grid-line-from/to ( orientation point -- from to )
|
||||||
half-gap v-
|
half-gap v-
|
||||||
|
@ -25,7 +25,7 @@ SYMBOL: grid-dim
|
||||||
M: grid-lines draw-boundary
|
M: grid-lines draw-boundary
|
||||||
origin get [
|
origin get [
|
||||||
-0.5 -0.5 0.0 glTranslated
|
-0.5 -0.5 0.0 glTranslated
|
||||||
grid-lines-color set-color [
|
color>> set-color [
|
||||||
dup grid set
|
dup grid set
|
||||||
dup rect-dim half-gap v- grid-dim set
|
dup rect-dim half-gap v- grid-dim set
|
||||||
compute-grid
|
compute-grid
|
||||||
|
|
|
@ -14,9 +14,9 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
|
||||||
HELP: grid
|
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."
|
{ $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
|
$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
|
$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
|
$nl
|
||||||
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
|
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
|
||||||
$nl
|
$nl
|
||||||
|
|
|
@ -48,7 +48,7 @@ grid
|
||||||
dupd add-gaps dim-sum v+ ;
|
dupd add-gaps dim-sum v+ ;
|
||||||
|
|
||||||
M: grid pref-dim*
|
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) ;
|
gap-sum >r gap-sum r> (pair-up) ;
|
||||||
|
|
||||||
: do-grid ( dims grid quot -- )
|
: do-grid ( dims grid quot -- )
|
||||||
|
@ -57,7 +57,7 @@ M: grid pref-dim*
|
||||||
drop ; inline
|
drop ; inline
|
||||||
|
|
||||||
: grid-positions ( grid dims -- locs )
|
: 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 -- )
|
: position-grid ( grid horiz vert -- )
|
||||||
pick >r
|
pick >r
|
||||||
|
@ -65,7 +65,7 @@ M: grid pref-dim*
|
||||||
pair-up r> [ set-rect-loc ] do-grid ;
|
pair-up r> [ set-rect-loc ] do-grid ;
|
||||||
|
|
||||||
: resize-grid ( grid horiz vert -- )
|
: resize-grid ( grid horiz vert -- )
|
||||||
pick grid-fill? [
|
pick fill?>> [
|
||||||
pair-up swap [ (>>dim) ] do-grid
|
pair-up swap [ (>>dim) ] do-grid
|
||||||
] [
|
] [
|
||||||
2drop grid>> [ [ prefer ] each ] each
|
2drop grid>> [ [ prefer ] each ] each
|
||||||
|
|
|
@ -24,20 +24,20 @@ TUPLE: incremental < pack cursor ;
|
||||||
|
|
||||||
M: incremental pref-dim*
|
M: incremental pref-dim*
|
||||||
dup layout-state>> [
|
dup layout-state>> [
|
||||||
dup call-next-method over set-incremental-cursor
|
dup call-next-method over (>>cursor)
|
||||||
] when incremental-cursor ;
|
] when cursor>> ;
|
||||||
|
|
||||||
: next-cursor ( gadget incremental -- cursor )
|
: next-cursor ( gadget incremental -- cursor )
|
||||||
[
|
[
|
||||||
swap rect-dim swap incremental-cursor
|
swap rect-dim swap cursor>>
|
||||||
2dup v+ >r vmax r>
|
2dup v+ >r vmax r>
|
||||||
] keep orientation>> set-axis ;
|
] keep orientation>> set-axis ;
|
||||||
|
|
||||||
: update-cursor ( gadget incremental -- )
|
: update-cursor ( gadget incremental -- )
|
||||||
[ next-cursor ] keep set-incremental-cursor ;
|
[ next-cursor ] keep (>>cursor) ;
|
||||||
|
|
||||||
: incremental-loc ( gadget incremental -- )
|
: incremental-loc ( gadget incremental -- )
|
||||||
dup incremental-cursor swap orientation>> v*
|
dup cursor>> swap orientation>> v*
|
||||||
swap set-rect-loc ;
|
swap set-rect-loc ;
|
||||||
|
|
||||||
: prefer-incremental ( gadget -- )
|
: prefer-incremental ( gadget -- )
|
||||||
|
@ -57,5 +57,5 @@ M: incremental pref-dim*
|
||||||
not-in-layout
|
not-in-layout
|
||||||
dup (clear-gadget)
|
dup (clear-gadget)
|
||||||
dup forget-pref-dim
|
dup forget-pref-dim
|
||||||
{ 0 0 } over set-incremental-cursor
|
{ 0 0 } over (>>cursor)
|
||||||
parent>> [ relayout ] when* ;
|
parent>> [ relayout ] when* ;
|
||||||
|
|
|
@ -16,7 +16,7 @@ TUPLE: labelled-gadget < track content ;
|
||||||
swap >>content
|
swap >>content
|
||||||
dup content>> 1 track-add ;
|
dup content>> 1 track-add ;
|
||||||
|
|
||||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
M: labelled-gadget focusable-child* content>> ;
|
||||||
|
|
||||||
: <labelled-scroller> ( gadget title -- gadget )
|
: <labelled-scroller> ( gadget title -- gadget )
|
||||||
>r <scroller> r> <labelled-gadget> ;
|
>r <scroller> r> <labelled-gadget> ;
|
||||||
|
@ -53,4 +53,4 @@ TUPLE: closable-gadget < frame content ;
|
||||||
swap >>content
|
swap >>content
|
||||||
dup content>> @center grid-add ;
|
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 -- )
|
: set-label-string ( string label -- )
|
||||||
CHAR: \n pick memq? [
|
CHAR: \n pick memq? [
|
||||||
>r string-lines r> set-label-text
|
>r string-lines r> (>>text)
|
||||||
] [
|
] [
|
||||||
set-label-text
|
(>>text)
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: label-theme ( gadget -- gadget )
|
: label-theme ( gadget -- gadget )
|
||||||
|
|
|
@ -27,8 +27,8 @@ TUPLE: list < pack index presenter color hook ;
|
||||||
control-value length 1- min 0 max ;
|
control-value length 1- min 0 max ;
|
||||||
|
|
||||||
: bound-index ( list -- )
|
: bound-index ( list -- )
|
||||||
dup list-index over calc-bounded-index
|
dup index>> over calc-bounded-index
|
||||||
swap set-list-index ;
|
swap (>>index) ;
|
||||||
|
|
||||||
: list-presentation-hook ( list -- quot )
|
: list-presentation-hook ( list -- quot )
|
||||||
hook>> [ [ list? ] find-parent ] prepend ;
|
hook>> [ [ list? ] find-parent ] prepend ;
|
||||||
|
@ -53,18 +53,18 @@ M: list model-changed
|
||||||
bound-index ;
|
bound-index ;
|
||||||
|
|
||||||
: selected-rect ( list -- rect )
|
: selected-rect ( list -- rect )
|
||||||
dup list-index swap children>> ?nth ;
|
dup index>> swap children>> ?nth ;
|
||||||
|
|
||||||
M: list draw-gadget*
|
M: list draw-gadget*
|
||||||
origin get [
|
origin get [
|
||||||
dup list-color set-color
|
dup color>> set-color
|
||||||
selected-rect [ rect-extent gl-fill-rect ] when*
|
selected-rect [ rect-extent gl-fill-rect ] when*
|
||||||
] with-translation ;
|
] with-translation ;
|
||||||
|
|
||||||
M: list focusable-child* drop t ;
|
M: list focusable-child* drop t ;
|
||||||
|
|
||||||
: list-value ( list -- object )
|
: list-value ( list -- object )
|
||||||
dup list-index swap control-value ?nth ;
|
dup index>> swap control-value ?nth ;
|
||||||
|
|
||||||
: scroll>selected ( list -- )
|
: scroll>selected ( list -- )
|
||||||
#! We change the rectangle's width to zero to avoid
|
#! We change the rectangle's width to zero to avoid
|
||||||
|
@ -79,22 +79,22 @@ M: list focusable-child* drop t ;
|
||||||
2drop
|
2drop
|
||||||
] [
|
] [
|
||||||
[ control-value length rem ] keep
|
[ control-value length rem ] keep
|
||||||
[ set-list-index ] keep
|
[ (>>index) ] keep
|
||||||
[ relayout-1 ] keep
|
[ relayout-1 ] keep
|
||||||
scroll>selected
|
scroll>selected
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: select-previous ( list -- )
|
: select-previous ( list -- )
|
||||||
dup list-index 1- swap select-index ;
|
dup index>> 1- swap select-index ;
|
||||||
|
|
||||||
: select-next ( list -- )
|
: select-next ( list -- )
|
||||||
dup list-index 1+ swap select-index ;
|
dup index>> 1+ swap select-index ;
|
||||||
|
|
||||||
: invoke-value-action ( list -- )
|
: invoke-value-action ( list -- )
|
||||||
dup list-empty? [
|
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 ;
|
] if ;
|
||||||
|
|
||||||
: select-gadget ( gadget list -- )
|
: select-gadget ( gadget list -- )
|
||||||
|
|
|
@ -173,7 +173,7 @@ M: pane-stream make-span-stream
|
||||||
>r pick at r> when* ; inline
|
>r pick at r> when* ; inline
|
||||||
|
|
||||||
: apply-foreground-style ( style gadget -- style gadget )
|
: 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 )
|
: apply-background-style ( style gadget -- style gadget )
|
||||||
background [ solid-interior ] apply-style ;
|
background [ solid-interior ] apply-style ;
|
||||||
|
@ -184,7 +184,7 @@ M: pane-stream make-span-stream
|
||||||
font-size swap at 12 or 3array ;
|
font-size swap at 12 or 3array ;
|
||||||
|
|
||||||
: apply-font-style ( style gadget -- style gadget )
|
: 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 )
|
: apply-presentation-style ( style gadget -- style gadget )
|
||||||
presented [ <presentation> ] apply-style ;
|
presented [ <presentation> ] apply-style ;
|
||||||
|
@ -255,7 +255,7 @@ M: pane-stream make-block-stream
|
||||||
|
|
||||||
! Tables
|
! Tables
|
||||||
: apply-table-gap-style ( style grid -- style grid )
|
: 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 )
|
: apply-table-border-style ( style grid -- style grid )
|
||||||
table-border [ <grid-lines> over (>>boundary) ]
|
table-border [ <grid-lines> over (>>boundary) ]
|
||||||
|
@ -263,7 +263,7 @@ M: pane-stream make-block-stream
|
||||||
|
|
||||||
: styled-grid ( style grid -- grid )
|
: styled-grid ( style grid -- grid )
|
||||||
<grid>
|
<grid>
|
||||||
f over set-grid-fill?
|
f over (>>fill?)
|
||||||
apply-table-gap-style
|
apply-table-gap-style
|
||||||
apply-table-border-style
|
apply-table-border-style
|
||||||
nip ;
|
nip ;
|
||||||
|
|
Loading…
Reference in New Issue