Fix ridiculous indentation, over (>>foo), and other crap in UI

db4
Slava Pestov 2008-09-27 14:36:04 -05:00
parent 016a1ed817
commit b7610e0bf7
38 changed files with 299 additions and 321 deletions

View File

@ -25,6 +25,6 @@ M: book model-changed ( model book -- )
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
M: book layout* ( book -- )
[ dim>> ] [ children>> ] bi [ (>>dim) ] with each ;
[ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
M: book focusable-child* ( book -- child/t ) current-page ;

View File

@ -10,7 +10,7 @@ TUPLE: border < gadget
{ align initial: { 1/2 1/2 } } ;
: new-border ( child class -- border )
new-gadget [ swap add-gadget drop ] keep ; inline
new-gadget swap add-gadget ; inline
: <border> ( child gap -- border )
swap border new-border

View File

@ -25,7 +25,7 @@ TUPLE: button < border pressed? selected? quot ;
dup mouse-clicked?
over button-rollover? and
buttons-down? and
over (>>pressed?)
>>pressed?
relayout-1 ;
: if-clicked ( button quot -- )
@ -115,20 +115,18 @@ M: checkmark-paint draw-interior
dup { 0 1 } v* swap { 1 0 } v* gl-line
] with-translation ;
: checkmark-theme ( gadget -- )
: checkmark-theme ( gadget -- gadget )
f
f
black <solid>
black <checkmark-paint>
<button-paint>
over (>>interior)
black <solid>
swap (>>boundary) ;
<button-paint> >>interior
black <solid> >>boundary ;
: <checkmark> ( -- gadget )
<gadget>
dup checkmark-theme
{ 14 14 } over (>>dim) ;
checkmark-theme
{ 14 14 } >>dim ;
: toggle-model ( model -- )
[ not ] change-model ;
@ -148,7 +146,7 @@ TUPLE: checkbox < button ;
align-left ;
M: checkbox model-changed
swap value>> over (>>selected?) relayout-1 ;
swap value>> >>selected? relayout-1 ;
TUPLE: radio-paint color ;
@ -162,20 +160,18 @@ M: radio-paint draw-boundary
color>> set-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
: radio-knob-theme ( gadget -- )
: radio-knob-theme ( gadget -- gadget )
f
f
black <radio-paint>
black <radio-paint>
<button-paint>
over (>>interior)
black <radio-paint>
swap (>>boundary) ;
<button-paint> >>interior
black <radio-paint> >>boundary ;
: <radio-knob> ( -- gadget )
<gadget>
dup radio-knob-theme
{ 16 16 } over (>>dim) ;
radio-knob-theme
{ 16 16 } >>dim ;
TUPLE: radio-control < button value ;
@ -188,8 +184,7 @@ TUPLE: radio-control < button value ;
M: radio-control model-changed
swap value>>
over value>> =
over (>>selected?)
over value>> = >>selected?
relayout-1 ;
: <radio-controls> ( parent model assoc quot -- parent )

View File

@ -96,9 +96,9 @@ M: editor ungraft*
: click-loc ( editor model -- )
>r clicked-loc r> set-model ;
: focus-editor ( editor -- ) t over (>>focused?) relayout-1 ;
: focus-editor ( editor -- ) t >>focused? relayout-1 ;
: unfocus-editor ( editor -- ) f over (>>focused?) relayout-1 ;
: unfocus-editor ( editor -- ) f >>focused? relayout-1 ;
: (offset>x) ( font col# str -- x )
swap head-slice string-width ;

View File

@ -9,9 +9,9 @@ IN: ui.gadgets.tests
! c contains b contains a
<gadget> "a" set
<gadget> "b" set
"a" get "b" get swap add-gadget drop
"b" get "a" get add-gadget drop
<gadget> "c" set
"b" get "c" get swap add-gadget drop
"c" get "b" get add-gadget drop
! position a and b
"a" get { 100 200 } >>loc drop
@ -33,8 +33,8 @@ IN: ui.gadgets.tests
<gadget> "g3" set
"g3" get { 100 200 } >>dim drop
"g1" get "g2" get swap add-gadget drop
"g2" get "g3" get swap add-gadget drop
"g2" get "g1" get add-gadget drop
"g3" get "g2" get add-gadget drop
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
@ -49,11 +49,11 @@ IN: ui.gadgets.tests
<gadget> "g1" set
"g1" get { 300 300 } >>dim drop
<gadget> "g2" set
"g2" get "g1" get swap add-gadget drop
"g1" get "g2" get add-gadget drop
"g2" get { 20 20 } >>loc
{ 20 20 } >>dim drop
<gadget> "g3" set
"g3" get "g1" get swap add-gadget drop
"g1" get "g3" get add-gadget drop
"g3" get { 100 100 } >>loc
{ 20 20 } >>dim drop
@ -66,7 +66,7 @@ IN: ui.gadgets.tests
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
<gadget> "g4" set
"g4" get "g2" get swap add-gadget drop
"g2" get "g4" get add-gadget drop
"g4" get { 5 5 } >>loc
{ 1 1 } >>dim drop
@ -121,7 +121,7 @@ M: mock-gadget ungraft*
: add-some-children
3 [
<mock-gadget> over <model> >>model
dup "g" get swap add-gadget drop
"g" get over add-gadget drop
swap 1+ number>string set
] each ;

View File

@ -147,7 +147,7 @@ M: array gadget-text*
DEFER: relayout
: invalidate* ( gadget -- )
\ invalidate* over (>>layout-state)
\ invalidate* >>layout-state
dup forget-pref-dim
dup root?>>
[ layout-later ] [ parent>> [ relayout ] when* ] if ;
@ -282,8 +282,7 @@ SYMBOL: in-layout?
: (clear-gadget) ( gadget -- )
dup [ (unparent) ] each-child
f over (>>focus)
f swap (>>children) ;
f >>focus f >>children drop ;
: clear-gadget ( gadget -- )
not-in-layout

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors
math.geometry.rect ;
math.geometry.rect locals ;
IN: ui.gadgets.grids
TUPLE: grid < gadget
@ -12,18 +12,18 @@ grid
: new-grid ( children class -- grid )
new-gadget
[ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
inline
swap >>grid
dup grid>> concat add-gadgets ; inline
: <grid> ( children -- grid )
grid new-grid ;
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( grid child i j -- grid )
>r >r dupd swap r> r>
>r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
:: grid-add ( grid child i j -- grid )
grid i j grid-child unparent
grid child add-gadget
child i j grid grid>> nth set-nth ;
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
@ -33,10 +33,10 @@ grid
: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
: compute-grid ( grid -- horiz vert )
pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
pref-dim-grid [ flip (compute-grid) ] [ (compute-grid) ] bi ;
: (pair-up) ( horiz vert -- dim )
>r first r> second 2array ;
[ first ] [ second ] bi* 2array ;
: pair-up ( horiz vert -- dims )
[ [ (pair-up) ] curry map ] with map ;

View File

@ -24,7 +24,7 @@ TUPLE: incremental < pack cursor ;
M: incremental pref-dim*
dup layout-state>> [
dup call-next-method over (>>cursor)
dup call-next-method >>cursor
] when cursor>> ;
: next-cursor ( gadget incremental -- cursor )
@ -57,5 +57,5 @@ M: incremental pref-dim*
not-in-layout
dup (clear-gadget)
dup forget-pref-dim
{ 0 0 } over (>>cursor)
{ 0 0 } >>cursor
parent>> [ relayout ] when* ;

View File

@ -22,20 +22,20 @@ M: labelled-gadget focusable-child* content>> ;
>r <scroller> r> <labelled-gadget> ;
: <labelled-pane> ( model quot scrolls? title -- gadget )
>r >r <pane-control> r> over (>>scrolls?) r>
>r >r <pane-control> r> >>scrolls? r>
<labelled-scroller> ;
: <close-box> ( quot -- button/f )
gray close-box <polygon-gadget> swap <bevel-button> ;
: title-theme ( gadget -- )
{ 1 0 } over (>>orientation)
: title-theme ( gadget -- gadget )
{ 1 0 } >>orientation
T{ gradient f {
T{ rgba f 0.65 0.65 1.0 1.0 }
T{ rgba f 0.65 0.45 1.0 1.0 }
} } swap (>>interior) ;
} } >>interior ;
: <title-label> ( text -- label ) <label> dup title-theme ;
: <title-label> ( text -- label ) <label> title-theme ;
: <title-bar> ( title quot -- gadget )
<frame>

View File

@ -49,7 +49,7 @@ TUPLE: list < pack index presenter color hook ;
M: list model-changed
nip
dup clear-gadget
dup <list-items> over swap add-gadgets drop
dup <list-items> add-gadgets
bound-index ;
: selected-rect ( list -- rect )
@ -79,8 +79,8 @@ M: list focusable-child* drop t ;
2drop
] [
[ control-value length rem ] keep
[ (>>index) ] keep
[ relayout-1 ] keep
swap >>index
dup relayout-1
scroll>selected
] if ;

View File

@ -15,19 +15,17 @@ TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass )
menu-glass new-gadget
>r over menu-loc >>loc r>
[ swap add-gadget drop ] keep ;
swap add-gadget ;
M: menu-glass layout* gadget-child prefer ;
: hide-glass ( world -- )
dup glass>> [ unparent ] when*
f swap (>>glass) ;
[ [ unparent ] when* f ] change-glass drop ;
: show-glass ( gadget world -- )
over hand-clicked set-global
[ hide-glass ] keep
[ swap add-gadget drop ] 2keep
(>>glass) ;
dup hide-glass
swap [ hand-clicked set-global ] [ >>glass ] bi
dup glass>> add-gadget drop ;
: show-menu ( gadget owner -- )
find-world [ <menu-glass> ] keep show-glass ;

View File

@ -40,7 +40,7 @@ TUPLE: pack < gadget
: <pile> ( -- pack ) { 0 1 } <pack> ;
: <filled-pile> ( -- pack ) <pile> 1 over (>>fill) ;
: <filled-pile> ( -- pack ) <pile> 1 >>fill ;
: <shelf> ( -- pack ) { 1 0 } <pack> ;

View File

@ -1,15 +1,15 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors
sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines classes.tuple models continuations
destructors accessors math.geometry.rect ;
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
ui.clipboards ui.gestures ui.traverse ui.render hashtables io
kernel namespaces sequences io.styles strings quotations math
opengl combinators math.vectors sorting splitting
io.streams.nested assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect ;
IN: ui.gadgets.panes
@ -17,23 +17,29 @@ TUPLE: pane < pack
output current prototype scrolls?
selection-color caret mark selecting? ;
: clear-selection ( pane -- pane ) f >>caret f >>mark ;
: clear-selection ( pane -- pane )
f >>caret f >>mark ;
: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
: add-output ( pane current -- pane )
[ >>output ] [ add-gadget ] bi ;
: add-current ( pane current -- pane )
[ >>current ] [ add-gadget ] bi ;
: prepare-line ( pane -- pane )
clear-selection
dup prototype>> clone add-current ;
: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;
: pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
M: pane gadget-selection ( pane -- string/f )
selected-children gadget-text ;
: pane-clear ( pane -- )
clear-selection
@ -132,7 +138,7 @@ M: style-stream write-gadget
: make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline
: <scrolling-pane> ( -- pane ) <pane> t over (>>scrolls?) ;
: <scrolling-pane> ( -- pane ) <pane> t >>scrolls? ;
TUPLE: pane-control < pane quot ;
@ -172,7 +178,7 @@ M: pane-stream make-span-stream
>r pick at r> when* ; inline
: apply-foreground-style ( style gadget -- style gadget )
foreground [ over (>>color) ] apply-style ;
foreground [ >>color ] apply-style ;
: apply-background-style ( style gadget -- style gadget )
background [ solid-interior ] apply-style ;
@ -183,7 +189,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 (>>font) ;
over specified-font >>font ;
: apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ;
@ -254,15 +260,15 @@ M: pane-stream make-block-stream
! Tables
: apply-table-gap-style ( style grid -- style grid )
table-gap [ over (>>gap) ] apply-style ;
table-gap [ >>gap ] apply-style ;
: apply-table-border-style ( style grid -- style grid )
table-border [ <grid-lines> over (>>boundary) ]
table-border [ <grid-lines> >>boundary ]
apply-style ;
: styled-grid ( style grid -- grid )
<grid>
f over (>>fill?)
f >>fill?
apply-table-gap-style
apply-table-border-style
nip ;
@ -286,13 +292,13 @@ M: pack dispose drop ;
M: paragraph dispose drop ;
: gadget-write ( string gadget -- )
over empty?
[ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
swap dup empty?
[ 2drop ] [ <label> text-theme add-gadget drop ] if ;
M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- )
>r " " <word-break-gadget> style-label r> swap add-gadget drop ;
swap " " <word-break-gadget> style-label add-gadget drop ;
M: paragraph stream-write
swap " " split
@ -309,8 +315,8 @@ M: paragraph stream-write1
[ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
: gadget-format ( string style stream -- )
pick empty?
[ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
spin dup empty?
[ 3drop ] [ <styled-label> add-gadget drop ] if ;
M: pack stream-format
gadget-format ;
@ -350,12 +356,10 @@ M: f sloppy-pick-up*
if ;
: move-caret ( pane -- pane )
dup hand-rel
over sloppy-pick-up
over (>>caret)
dup hand-rel over sloppy-pick-up >>caret
dup relayout-1 ;
: begin-selection ( pane -- ) move-caret f swap (>>mark) ;
: begin-selection ( pane -- ) move-caret f >>mark drop ;
: extend-selection ( pane -- )
hand-moved? [

View File

@ -17,8 +17,8 @@ TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget )
paragraph new-gadget
{ 1 0 } over (>>orientation)
[ (>>margin) ] keep ;
{ 1 0 } >>orientation
swap >>margin ;
SYMBOL: x SYMBOL: max-x

View File

@ -61,7 +61,7 @@ IN: ui.gadgets.scrollers.tests
<gadget> { 600 400 } >>dim "g1" set
<gadget> { 600 10 } >>dim "g2" set
"g2" get "g1" get swap add-gadget drop
"g1" get "g2" get add-gadget drop
"g1" get <scroller>
{ 300 300 } >>dim

View File

@ -81,7 +81,7 @@ scroller H{
: scroll>rect ( rect gadget -- )
dup find-scroller* dup [
[ relative-scroll-rect ] keep
[ (>>follows) ] keep
swap >>follows
relayout
] [
3drop
@ -94,7 +94,7 @@ scroller H{
: scroll>gadget ( gadget -- )
dup find-scroller* dup [
[ (>>follows) ] keep
swap >>follows
relayout
] [
2drop
@ -104,9 +104,7 @@ scroller H{
dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
: scroll>bottom ( gadget -- )
find-scroller [
t over (>>follows) relayout-1
] when* ;
find-scroller [ t >>follows relayout-1 ] when* ;
: scroll>top ( gadget -- )
<zero-rect> swap scroll>rect ;

View File

@ -83,7 +83,7 @@ thumb H{
dup direction>> swap find-slider slide-by-page ;
: elevator-click ( elevator -- )
dup compute-direction over (>>direction)
dup compute-direction >>direction
elevator-hold ;
elevator H{
@ -123,7 +123,7 @@ M: elevator layout*
: <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button>
[ (>>orientation) ] keep ;
swap >>orientation ;
: elevator, ( gadget orientation -- gadget )
tuck <elevator> >>elevator

View File

@ -54,13 +54,10 @@ M: track pref-dim* ( gadget -- dim )
pick sizes>> push add-gadget ;
: track-remove ( track gadget -- track )
dupd dup
[
dupd dup [
[ swap children>> index ]
[ unparent sizes>> ] 2bi
delete-nth
]
[ 2drop ]
if ;
] [ 2drop ] if ;
: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;

View File

@ -18,7 +18,7 @@ TUPLE: viewport < gadget ;
viewport new-gadget
swap >>model
t >>clipped?
[ swap add-gadget drop ] keep ;
swap add-gadget ;
M: viewport layout*
dup rect-dim viewport-gap 2 v*n v-

View File

@ -18,7 +18,7 @@ IN: ui.gadgets.worlds.tests
<gadget> "g1" set
<gadget> "g2" set
"g1" get "g2" get swap add-gadget drop
"g2" get "g1" get add-gadget drop
[ ] [
"g2" get <test-world> "w" set
@ -33,8 +33,8 @@ IN: ui.gadgets.worlds.tests
<gadget> "g1" set
<gadget> "g2" set
<gadget> "g3" set
"g1" get "g3" get swap add-gadget drop
"g2" get "g3" get swap add-gadget drop
"g3" get "g1" get add-gadget drop
"g3" get "g2" get add-gadget drop
[ ] [
"g3" get <test-world> "w" set
@ -55,7 +55,7 @@ TUPLE: focus-test < gadget ;
: <focus-test>
focus-test new-gadget
<focusing> over swap add-gadget drop ;
dup <focusing> add-gadget drop ;
M: focus-test focusable-child* gadget-child ;

View File

@ -19,8 +19,7 @@ TUPLE: operation predicate command translator hook listener? ;
swap >>predicate ;
PREDICATE: listener-operation < operation
dup command>> listener-command?
swap listener?>> or ;
[ command>> listener-command? ] [ listener?>> ] bi or ;
M: operation command-name
command>> command-name ;
@ -59,15 +58,15 @@ SYMBOL: operations
: modify-operation ( hook translator operation -- operation )
clone
tuck (>>translator)
tuck (>>hook)
t over (>>listener?) ;
swap >>translator
swap >>hook
t >>listener? ;
: modify-operations ( operations hook translator -- operations )
rot [ >r 2dup r> modify-operation ] map 2nip ;
rot [ modify-operation ] with with map ;
: operations>commands ( object hook translator -- pairs )
>r >r object-operations r> r> modify-operations
[ object-operations ] 2dip modify-operations
[ [ operation-gesture ] keep ] { } map>assoc ;
: define-operation-map ( class group blurb object hook translator -- )

View File

@ -139,7 +139,7 @@ M: polygon draw-interior
: <polygon-gadget> ( color points -- gadget )
dup max-dim
>r <polygon> <gadget> r> >>dim
[ (>>interior) ] keep ;
swap >>interior ;
! Font rendering
SYMBOL: font-renderer

View File

@ -57,7 +57,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
advanced-settings
deploy-settings-theme
namespace <mapping> over (>>model)
namespace <mapping> >>model
]
bind ;

View File

@ -124,8 +124,7 @@ TUPLE: stack-display < track ;
listener>>
{ 0 1 } stack-display new-track
over <toolbar> f track-add
swap
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add ;
M: stack-display tool-scroller

View File

@ -65,7 +65,6 @@ search-field H{
dup field>> f track-add
-roll <search-list> >>list
dup list>> <scroller> 1 track-add
swap
over field>> set-editor-string
dup field>> end-of-document ;

View File

@ -19,21 +19,16 @@ IN: ui.tools
<toggle-buttons> ;
: <workspace-book> ( workspace -- gadget )
dup
<stack-display>
<browser-gadget>
<inspector-gadget>
<profiler-gadget>
4array
swap model>>
<book> ;
swap model>> <book> ;
: <workspace> ( -- workspace )
{ 0 1 } workspace new-track
0 <model> >>model
<listener-gadget> >>listener
dup <workspace-book> >>book

View File

@ -51,12 +51,12 @@ SYMBOL: stop-after-last-window?
T{ gain-focus } swap each-gesture ;
: focus-world ( world -- )
t over (>>focused?)
t >>focused?
dup raised-window
focus-path f focus-gestures ;
: unfocus-world ( world -- )
f over (>>focused?)
f >>focused?
focus-path f swap focus-gestures ;
M: world graft*
@ -93,13 +93,8 @@ SYMBOL: ui-hook
dup graft-state>> {
{ { f f } [ ] }
{ { f t } [ ] }
{ { t t } [
{ f f } over (>>graft-state)
] }
{ { t f } [
dup unqueue-graft
{ f f } over (>>graft-state)
] }
{ { t t } [ { f f } >>graft-state ] }
{ { t f } [ dup unqueue-graft { f f } >>graft-state ] }
} case graft-later ;
: restore-gadget ( gadget -- )
@ -172,7 +167,7 @@ SYMBOL: ui-thread
"UI update" spawn drop ;
: open-world-window ( world -- )
dup pref-dim over (>>dim) dup relayout graft ;
dup pref-dim >>dim dup relayout graft ;
: open-window ( gadget title -- )
f <world> open-world-window ;

View File

@ -21,8 +21,8 @@ C: <x11-handle> x11-handle
M: world expose-event nip relayout ;
M: world configure-event
over configured-loc over (>>window-loc)
swap configured-dim over (>>dim)
over configured-loc >>window-loc
swap configured-dim >>dim
! In case dimensions didn't change
relayout-1 ;