--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math kernel sets generic
+ui.baseline-alignment ui.baseline-alignment.private ;
+IN: ui.baseline-alignment.tests
+
+! Test baseline calculations
+[ 10 ] [ 0 10 0 combine-metrics + ] unit-test
+[ 15 ] [ 0 10 5 combine-metrics + ] unit-test
+[ 30 ] [ 30 0 0 combine-metrics + ] unit-test
+[ 35 ] [ 10 0 30 combine-metrics + ] unit-test
+[ 20 ] [ 5 10 10 combine-metrics + ] unit-test
+[ 20 ] [ 20 10 0 combine-metrics + ] unit-test
+[ 55 ] [ 20 10 40 combine-metrics + ] unit-test
+
+[ t ] [ \ baseline \ cap-height [ order ] bi@ set= ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel locals math math.order math.vectors
+sequences ui.gadgets accessors ;
+IN: ui.baseline-alignment
+
+SYMBOL: +baseline+
+
+GENERIC: baseline ( gadget -- y )
+
+M: gadget baseline drop f ;
+
+GENERIC: cap-height ( gadget -- y )
+
+M: gadget cap-height drop f ;
+
+<PRIVATE
+
+! Text has ascent/descent/cap-height slots, graphics does not.
+TUPLE: gadget-metrics height ascent descent cap-height ;
+
+: <gadget-metrics> ( gadget dim -- metrics )
+ second swap [ baseline ] [ cap-height ] bi
+ [ dup [ 2dup - ] [ f ] if ] dip
+ gadget-metrics boa ; inline
+
+: max-ascent ( seq -- n )
+ 0 [ ascent>> [ max ] when* ] reduce ; inline
+
+: max-descent ( seq -- n )
+ 0 [ descent>> [ max ] when* ] reduce ; inline
+
+: max-text-height ( seq -- y )
+ 0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
+
+: max-graphics-height ( seq -- y )
+ 0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
+
+: combine-metrics ( graphics-height ascent descent -- ascent' descent' )
+ [ [ [-] 2 /i ] keep ] dip [ + ] [ max ] bi-curry* bi ;
+
+PRIVATE>
+
+:: align-baselines ( gadgets -- ys )
+ gadgets [ dup pref-dim <gadget-metrics> ] map
+ dup max-ascent :> max-ascent
+ dup max-graphics-height :> max-height
+ max-height max-ascent [-] 2 /i :> offset-text
+ max-ascent max-height [-] 2 /i :> offset-graphics
+ [
+ dup ascent>> [
+ ascent>>
+ max-ascent
+ offset-text
+ ] [
+ height>>
+ max-height
+ offset-graphics
+ ] if [ swap - ] dip +
+ ] map ;
+
+: measure-metrics ( children sizes -- ascent descent )
+ [ <gadget-metrics> ] 2map
+ [ max-graphics-height ] [ max-ascent ] [ max-descent ] tri
+ combine-metrics ;
+
+: measure-height ( children sizes -- height )
+ measure-metrics + ;
\ No newline at end of file
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gadgets kernel math fry
+USING: accessors arrays ui.gadgets ui.baseline-alignment kernel math fry
namespaces vectors sequences math.vectors math.rectangles ;
IN: ui.gadgets.borders
M: border pref-dim*
dup gadget-child pref-dim border-pref-dim ;
-M: border baseline
- [ size>> second ] [ gadget-child baseline ] bi
- dup [ + ] [ nip ] if ;
-
<PRIVATE
: border-major-dim ( border -- dim )
: border-child-rect ( border -- rect )
dup border-dim [ border-loc ] keep <rect> ;
+: border-metric ( border quot -- n )
+ [ drop size>> second ] [ [ gadget-child ] dip call ] 2bi
+ dup [ + ] [ nip ] if ; inline
+
PRIVATE>
+M: border baseline [ baseline ] border-metric ;
+
+M: border cap-height [ cap-height ] border-metric ;
+
M: border layout*
[ border-child-rect ] [ gadget-child ] bi set-rect-bounds ;
\ <radio-buttons> must-infer
-\ <toggle-buttons> must-infer
-
\ <checkbox> must-infer
[ 0 ] [
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors ui ui.gadgets ui.gadgets.buttons ui.render ;
+USING: kernel accessors sequences ui ui.gadgets ui.gadgets.buttons
+ui.baseline-alignment ui.render ;
IN: ui.gadgets.debug
TUPLE: baseline-gadget < gadget baseline ;
M: baseline-gadget baseline baseline>> ;
+M: baseline-gadget cap-height dim>> second ;
+
: <baseline-gadget> ( baseline dim -- gadget )
baseline-gadget new
swap >>dim
colors.constants combinators assocs math.order fry calendar alarms
continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.menus ui.gadgets.wrappers ui.render
-ui.pens.solid ui.gadgets.line-support ui.text ui.gestures
+ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid
+ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment
math.rectangles splitting unicode.categories fonts grouping ;
IN: ui.gadgets.editors
M: editor pref-dim*
[ font>> ] [ control-value ] bi text-dim ;
-M: editor baseline
- font>> font-metrics ascent>> ;
+M: editor baseline font>> font-metrics ascent>> ;
+
+M: editor cap-height font>> font-metrics cap-height>> ;
: contents-changed ( model editor -- )
swap
<PRIVATE
-: page-elt ( editor -- editor element ) dup visible-lines <page-elt> ;
+: page-elt ( editor -- editor element ) dup visible-lines 1- <page-elt> ;
PRIVATE>
USING: accessors ui.gadgets ui.gadgets.private ui.gadgets.packs
ui.gadgets.worlds tools.test namespaces models kernel dlists deques
math sets math.parser ui sequences hashtables assocs io arrays
-prettyprint io.streams.string math.rectangles ui.gadgets.private ;
+prettyprint io.streams.string math.rectangles ui.gadgets.private
+sets generic ;
IN: ui.gadgets.tests
[ { 300 300 } ]
\ pref-dim must-infer
\ graft* must-infer
-\ ungraft* must-infer
-
-! Test baseline calculations
-[ 10 ] [ 0 10 0 combine-baseline-metrics + ] unit-test
-[ 15 ] [ 0 10 5 combine-baseline-metrics + ] unit-test
-[ 30 ] [ 30 0 0 combine-baseline-metrics + ] unit-test
-[ 35 ] [ 10 0 30 combine-baseline-metrics + ] unit-test
-[ 20 ] [ 5 10 10 combine-baseline-metrics + ] unit-test
-[ 20 ] [ 20 10 0 combine-baseline-metrics + ] unit-test
-[ 55 ] [ 20 10 40 combine-baseline-metrics + ] unit-test
\ No newline at end of file
+\ ungraft* must-infer
\ No newline at end of file
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals ;
+concurrency.flags math.order math.rectangles fry ;
IN: ui.gadgets
! Values for orientation slot
M: gadget pref-dim* dim>> ;
-SYMBOL: +baseline+
-
-GENERIC: baseline ( gadget -- y )
-
-M: gadget baseline drop f ;
-
-: (max-ascent-and-descent) ( accum baseline height -- accum' )
- over [ over - 2array vmax ] [ 2drop ] if ;
-
-: max-ascent-and-descent ( baselines heights -- ascent descent )
- { 0 0 } [ (max-ascent-and-descent) ] 2reduce first2 ;
-
-: max-height-with-baseline ( baselines heights -- y )
- 0 [ swap [ max ] [ drop ] if ] 2reduce ;
-
-: max-height-without-baseline ( baselines heights -- y )
- 0 [ swap [ drop ] [ max ] if ] 2reduce ;
-
-:: baseline-align ( gadgets -- ys )
- gadgets [ [ baseline ] map ] [ [ pref-dim second ] map ] bi
- over 0 [ [ max ] when* ] reduce :> max-baseline
- 2dup max-height-without-baseline :> max-height-without-baseline
- max-height-without-baseline max-baseline [-] 2 /i :> offset-with-baseline
- max-baseline max-height-without-baseline [-] 2 /i :> offset-without-baseline
- [
- over [
- drop
- max-baseline
- offset-with-baseline
- ] [
- nip
- max-height-without-baseline
- offset-without-baseline
- ] if [ swap - ] dip +
- ] 2map ;
-
-: combine-baseline-metrics ( height ascent descent -- ascent' descent' )
- [ [ [-] 2 /i ] keep ] dip [ + ] [ max ] bi-curry* bi ;
-
-: baseline-metrics ( children sizes -- ascent descent )
- #! Consider gadgets with a baseline and those without separately.
- [ [ baseline ] map ] [ [ second ] map ] bi*
- [ max-height-without-baseline ] [ max-ascent-and-descent ] 2bi
- combine-baseline-metrics ;
-
-: baseline-height ( children sizes -- height )
- baseline-metrics + ;
-
GENERIC: layout* ( gadget -- )
M: gadget layout* drop ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.order namespaces make sequences words io
-math.vectors ui.gadgets columns accessors strings.tables
+math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
math.rectangles fry ;
IN: ui.gadgets.grids
: cross-zip ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map ;
-TUPLE: cell pref-dim baseline ;
+TUPLE: cell pref-dim baseline cap-height ;
-: <cell> ( gadget -- cell ) [ pref-dim ] [ baseline ] bi cell boa ;
+: <cell> ( gadget -- cell )
+ [ pref-dim ] [ baseline ] [ cap-height ] tri cell boa ;
M: cell baseline baseline>> ;
+M: cell cap-height cap-height>> ;
+
TUPLE: grid-layout grid gap fill? row-heights column-widths ;
: iterate-cell-dims ( cells quot -- seq )
: row-heights ( grid-layout -- heights )
[ grid>> ] [ fill?>> ] bi
[ [ second ] iterate-cell-dims ]
- [ [ dup [ pref-dim>> ] map baseline-height ] map ]
+ [ [ dup [ pref-dim>> ] map measure-height ] map ]
if ;
: column-widths ( grid-layout -- widths )
bi cross-zip flip ;
: adjust-for-baseline ( row-locs row-cells -- row-locs' )
- baseline-align [ 0 swap 2array v+ ] 2map ;
+ align-baselines [ 0 swap 2array v+ ] 2map ;
: cell-locs ( grid-layout -- locs )
dup fill?>>
USING: accessors arrays hashtables io kernel math math.functions
namespaces make opengl sequences strings splitting ui.gadgets
ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.pens.solid
-ui.text colors colors.constants models combinators ;
+ui.baseline-alignment ui.text colors colors.constants models
+combinators ;
IN: ui.gadgets.labels
! A label gadget draws a string.
M: label pref-dim*
>label< text-dim ;
+<PRIVATE
+
+: label-metrics ( label -- metrics )
+ >label< dup string? [ first ] unless line-metrics ;
+
+PRIVATE>
+
M: label baseline
- >label< dup string? [ first ] unless
- line-metrics ascent>> round ;
+ label-metrics ascent>> round ;
+
+M: label cap-height
+ label-metrics cap-height>> round ;
M: label draw-gadget*
>label<
2bi 2array ;
: visible-lines ( gadget -- n )
- [ visible-dim second ] [ line-height ] bi /i 1- ;
\ No newline at end of file
+ [ visible-dim second ] [ line-height ] bi /i ;
\ No newline at end of file
USING: ui.gadgets help.markup help.syntax generic kernel
-classes.tuple quotations ui.gadgets.packs.private ;
+classes.tuple quotations ui.gadgets.packs.private
+ui.baseline-alignment ;
IN: ui.gadgets.packs
ARTICLE: "ui-pack-layout" "Pack layouts"
-USING: ui.gadgets.packs ui.gadgets.packs.private ui.gadgets.labels
-ui.gadgets ui.gadgets.debug ui.render kernel namespaces tools.test
-math.parser sequences math.rectangles accessors ;
+USING: ui.gadgets.packs ui.gadgets.packs.private
+ui.gadgets.labels ui.gadgets ui.gadgets.debug ui.render
+ui.baseline-alignment kernel namespaces tools.test math.parser
+sequences math.rectangles accessors ;
IN: ui.gadgets.packs.tests
[ t ] [
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences ui.gadgets kernel math math.functions
-math.vectors math.order math.rectangles namespaces accessors
-fry combinators arrays ;
+USING: sequences ui.gadgets ui.baseline-alignment kernel math
+math.functions math.vectors math.order math.rectangles namespaces
+accessors fry combinators arrays ;
IN: ui.gadgets.packs
TUPLE: pack < gadget
[ align>> ] [ dim>> ] bi '[ [ _ _ ] dip v- [ * >integer ] with map ] map ;
: baseline-aligned-locs ( pack -- seq )
- children>> baseline-align [ 0 swap 2array ] map ;
+ children>> align-baselines [ 0 swap 2array ] map ;
: aligned-locs ( sizes pack -- seq )
dup align>> +baseline+ eq?
: max-pack-dim ( pack sizes -- dim )
over align>> +baseline+ eq?
- [ [ children>> ] dip baseline-height 0 swap 2array ] [ nip max-dim ] if ;
+ [ [ children>> ] dip measure-height 0 swap 2array ] [ nip max-dim ] if ;
: pack-pref-dim ( pack sizes -- dim )
[ max-pack-dim ]
dup children>> pref-dims pack-pref-dim ;
: vertical-baseline ( pack -- y )
- children>> [ 0 ] [ first baseline ] if-empty ;
+ children>> [ f ] [ first baseline ] if-empty ;
: horizontal-baseline ( pack -- y )
- children>> dup pref-dims baseline-metrics drop ;
+ children>> dup pref-dims measure-metrics drop ;
+
+: pack-cap-height ( pack -- n )
+ children>> [ f ] [ first cap-height ] if-empty ;
PRIVATE>
{ horizontal [ horizontal-baseline ] }
} case ;
+M: pack cap-height pack-cap-height ;
+
M: pack layout*
dup children>> pref-dims pack-layout ;
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 io.styles ;
+ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment
+colors call io.styles ;
IN: ui.gadgets.panes
TUPLE: pane < pack
! Copyright (C) 2005, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.order sequences wrap wrap.words
-arrays fry ui.gadgets ui.gadgets.labels ui.render ;
+arrays fry ui.gadgets ui.gadgets.labels ui.gadgets.packs.private
+ui.render ui.baseline-alignment ;
IN: ui.gadgets.paragraphs
MIXIN: word-break
TUPLE: line words height ;
: <line> ( words -- line )
- dup [ key>> ] map dup pref-dims baseline-height line boa ;
+ dup [ key>> ] map dup pref-dims measure-height line boa ;
: wrap-paragraph ( paragraph -- wrapped-paragraph )
[ children>> [ gadget>word ] map ] [ margin>> ] bi
words>>
[ ]
[ word-x-coordinates ]
- [ [ key>> ] map baseline-align ] tri
+ [ [ key>> ] map align-baselines ] tri
] dip '[ _ + layout-word ] 3each ;
M: paragraph layout*
first words>>
[ key>> ] map
dup [ pref-dim ] map
- baseline-metrics drop
+ measure-metrics drop
] if-empty ;
+M: paragraph cap-height pack-cap-height ;
+
PRIVATE>
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel delegate fry sequences models models.search
-models.delay calendar locals ui.pens ui.pens.image ui.gadgets.editors
-ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.tables
-ui.gadgets.tracks ui.gadgets.borders ui.gadgets.buttons ui.gadgets ;
+USING: accessors kernel delegate fry sequences models
+models.search models.delay calendar locals ui.pens ui.pens.image
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.borders
+ui.gadgets.buttons ui.baseline-alignment ui.gadgets ;
IN: ui.gadgets.search-tables
TUPLE: search-field < track field ;
dup control-value length 1- select-row ;
: prev/next-page ( table n -- )
- over visible-lines * prev/next-row ;
+ over visible-lines 1- * prev/next-row ;
: previous-page ( table -- )
-1 prev/next-page ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.gadgets kernel ;
+USING: accessors kernel ui.gadgets ui.baseline-alignment ;
IN: ui.gadgets.wrappers
TUPLE: wrapper < gadget ;
M: wrapper baseline gadget-child baseline ;
+M: wrapper cap-height gadget-child cap-height ;
+
M: wrapper layout* [ gadget-child ] [ dim>> ] bi >>dim drop ;
M: wrapper focusable-child* gadget-child ;
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel quotations accessors fry
-assocs present math.order math.vectors arrays locals
-models.search models.sort models sequences vocabs
-tools.profiler words prettyprint ui ui.commands ui.gadgets
-ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables
-ui.gadgets.labeled ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.labels ui.gadgets.tabbed ui.gadgets.status-bar
-ui.gadgets.borders ui.tools.browser ui.tools.common ;
+USING: kernel quotations accessors fry assocs present math.order
+math.vectors arrays locals models.search models.sort models
+sequences vocabs tools.profiler words prettyprint ui ui.commands
+ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.tracks ui.gestures ui.gadgets.buttons
+ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled
+ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels
+ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders
+ui.tools.browser ui.tools.common ui.baseline-alignment ;
FROM: models.filter => <filter> ;
FROM: models.compose => <compose> ;
IN: ui.tools.profiler