diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index d9d77cc8b9..a5ddefcf95 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,8 +1,11 @@ - reader syntax for arrays, byte arrays, displaced aliens - fix infer hang +- out of memory error when printing global namespace +- HTML formatting + ui: +- adding/removing timers automatically for animated gadgets - fix listener prompt display after presentation commands invoked - theme abstraction in ui - menu dragging @@ -76,6 +79,8 @@ + kernel: +- merge timers with sleeping tasks +- what about tasks and timers between image restarts - split: return vectors - specialized arrays - there is a problem with hashcodes of words and bootstrapping diff --git a/library/collections/sequence-sort.factor b/library/collections/sequence-sort.factor index 6555bdd31f..adc77ef4bb 100644 --- a/library/collections/sequence-sort.factor +++ b/library/collections/sequence-sort.factor @@ -82,6 +82,13 @@ IN: sequences swap dup empty? [ 3drop -1 ] [ binsearch-slice (binsearch) ] ifte ; inline - + +: binsearch* ( elt seq quot -- elt | quot: elt elt -- -1/0/1 ) + over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] ifte ; + inline + : binsearch-range ( from to seq quot -- from to ) - [ binsearch ] 2keep rot >r binsearch r> ; + [ binsearch 0 max ] 2keep rot >r binsearch 1 + r> ; inline + +: binsearch-slice ( from to seq quot -- slice ) + over >r binsearch-range r> ; inline diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index f568030ae9..6ea15585d2 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -4,10 +4,6 @@ IN: prettyprint USING: alien generic hashtables io kernel lists math namespaces parser sequences strings styles vectors words ; -! TODO: -! - out of memory when printing global namespace -! - formatting HTML code - ! State SYMBOL: column SYMBOL: indent @@ -110,11 +106,8 @@ C: block ( -- block ) [ section-end fresh-line ] [ drop ] ifte ; : advance ( section -- ) - section-start last-newline get = [ - last-newline inc - ] [ - " " write - ] ifte ; + section-start last-newline get = + [ last-newline inc ] [ " " write ] ifte ; : pprint-section ( section -- ) last-newline? get [ @@ -198,7 +191,7 @@ M: complex pprint* ( num -- ) \ }# pprint-word ; : ch>ascii-escape ( ch -- esc ) - [ + {{ [[ CHAR: \e "\\e" ]] [[ CHAR: \n "\\n" ]] [[ CHAR: \r "\\r" ]] @@ -206,7 +199,7 @@ M: complex pprint* ( num -- ) [[ CHAR: \0 "\\0" ]] [[ CHAR: \\ "\\\\" ]] [[ CHAR: \" "\\\"" ]] - ] assoc ; + }} hash ; : ch>unicode-escape ( ch -- esc ) >hex 4 CHAR: 0 pad-left "\\u" swap append ; @@ -290,7 +283,11 @@ M: tuple pprint* ( tuple -- ) [ \ << \ >> pprint-sequence ] check-recursion ; M: alien pprint* ( alien -- ) - \ ALIEN: pprint-word bl alien-address number>string f text ; + dup expired? [ + drop "( alien expired )" + ] [ + \ ALIEN: pprint-word bl alien-address number>string + ] ifte f text ; M: wrapper pprint* ( wrapper -- ) dup wrapped word? [ diff --git a/library/test/gadgets/rectangles.factor b/library/test/gadgets/rectangles.factor index c41cad04d7..5ff78d0e83 100644 --- a/library/test/gadgets/rectangles.factor +++ b/library/test/gadgets/rectangles.factor @@ -2,28 +2,28 @@ USING: gadgets kernel namespaces test ; [ t ] [ [ { 2000 2000 0 } origin set - { 2030 2040 0 } { 10 20 0 } { 300 400 0 } inside? + { 2030 2040 0 } { 10 20 0 } { 300 400 0 } inside? ] with-scope ] unit-test [ f ] [ [ { 2000 2000 0 } origin set - { 2500 2040 0 } { 10 20 0 } { 300 400 0 } inside? + { 2500 2040 0 } { 10 20 0 } { 300 400 0 } inside? ] with-scope ] unit-test [ t ] [ [ { -10 -20 0 } origin set - { 0 0 0 } { 10 20 0 } { 300 400 0 } inside? + { 0 0 0 } { 10 20 0 } { 300 400 0 } inside? ] with-scope ] unit-test [ f ] [ [ { 0 0 0 } origin set - { 10 10 0 } { 0 0 0 } { 10 10 0 } inside? + { 10 10 0 } { 0 0 0 } { 10 10 0 } inside? ] with-scope ] unit-test @@ -40,3 +40,15 @@ USING: gadgets kernel namespaces test ; << rectangle f { 200 200 0 } { 40 40 0 } >> intersect ] unit-test + +[ f ] [ + << rectangle f { 100 100 0 } { 50 50 0 } >> + << rectangle f { 200 200 0 } { 40 40 0 } >> + intersects? +] unit-test + +[ t ] [ + << rectangle f { 100 100 0 } { 50 50 0 } >> + << rectangle f { 120 120 0 } { 40 40 0 } >> + intersects? +] unit-test diff --git a/library/threads.factor b/library/threads.factor index 8fc21eb7e7..ba23d2ccab 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -63,7 +63,7 @@ GENERIC: tick ( ms object -- ) : timers ( -- hash ) \ timers global hash ; : add-timer ( object delay -- ) - [ ] keep timers set-hash ; + over >r r> timers set-hash ; : remove-timer ( object -- ) timers remove-hash ; diff --git a/library/ui/books.factor b/library/ui/books.factor index eade0aef97..c8f7d9c3a1 100644 --- a/library/ui/books.factor +++ b/library/ui/books.factor @@ -14,9 +14,9 @@ M: book pref-dim ( book -- dim ) gadget-children { 0 0 0 } [ pref-dim vmax ] reduce ; M: book layout* ( book -- ) - dup rectangle-dim over gadget-children [ + dup rect-dim over gadget-children [ f over set-gadget-visible? - { 0 0 0 } over set-rectangle-loc + { 0 0 0 } over set-rect-loc set-gadget-dim ] each-with dup book-page swap gadget-children nth diff --git a/library/ui/borders.factor b/library/ui/borders.factor index 8df8922dd0..90eec1b71f 100644 --- a/library/ui/borders.factor +++ b/library/ui/borders.factor @@ -21,10 +21,10 @@ C: border ( child delegate size -- border ) { 5 5 0 } ; : layout-border-loc ( border -- ) - dup border-size swap gadget-child set-rectangle-loc ; + dup border-size swap gadget-child set-rect-loc ; : layout-border-dim ( border -- ) - dup rectangle-dim over border-size 2 v*n v- + dup rect-dim over border-size 2 v*n v- swap gadget-child set-gadget-dim ; M: border pref-dim ( border -- dim ) diff --git a/library/ui/editors.factor b/library/ui/editors.factor index eccf25bd09..91ea21a438 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -17,10 +17,10 @@ C: caret ( -- caret ) M: caret tick* ( ms caret -- ) nip toggle-visible ; -: caret-block 500 ; +: caret-blink 500 ; : add-caret ( caret parent -- ) - dupd add-gadget caret-block add-timer ; + dupd add-gadget caret-blink add-timer ; : unparent-caret ( caret -- ) dup remove-timer unparent ; @@ -100,7 +100,7 @@ C: editor ( text -- ) 0 0 3vector ; : caret-dim ( editor -- w h ) - rectangle-dim { 0 1 1 } v* { 1 0 0 } v+ ; + rect-dim { 0 1 1 } v* { 1 0 0 } v+ ; M: editor user-input* ( ch editor -- ? ) [ insert-char ] with-editor t ; @@ -110,7 +110,7 @@ M: editor pref-dim ( editor -- dim ) M: editor layout* ( editor -- ) dup editor-caret over caret-dim swap set-gadget-dim - dup editor-caret swap caret-loc swap set-rectangle-loc ; + dup editor-caret swap caret-loc swap set-rect-loc ; M: editor draw-gadget* ( editor -- ) dup delegate draw-gadget* diff --git a/library/ui/frames.factor b/library/ui/frames.factor index 194187b1b2..e276b3bcf9 100644 --- a/library/ui/frames.factor +++ b/library/ui/frames.factor @@ -72,11 +72,11 @@ SYMBOL: frame-bottom-run : var-frame-top \ frame-top var-frame-y ; : var-frame-right dup \ frame-right var-frame-x - swap rectangle-dim first \ frame-right [ - ] change + swap rect-dim first \ frame-right [ - ] change \ frame-right get \ frame-left get - frame-right-run set ; : var-frame-bottom dup \ frame-bottom var-frame-y - swap rectangle-dim second \ frame-bottom [ - ] change + swap rect-dim second \ frame-bottom [ - ] change \ frame-bottom get \ frame-top get - frame-bottom-run set ; : setup-frame ( frame -- ) @@ -86,7 +86,7 @@ SYMBOL: frame-bottom-run var-frame-bottom ; : move-gadget ( x y gadget -- ) - >r 0 3vector r> set-rectangle-loc ; + >r 0 3vector r> set-rect-loc ; : reshape-gadget ( x y w h gadget -- ) [ >r 0 3vector r> set-gadget-dim ] keep move-gadget ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 9a9f063303..6eab81b9c6 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -8,27 +8,33 @@ SYMBOL: origin global [ { 0 0 0 } origin set ] bind -TUPLE: rectangle loc dim ; +TUPLE: rect loc dim ; -GENERIC: inside? ( loc shape -- ? ) +GENERIC: inside? ( loc rect -- ? ) -: shape-bounds ( shape -- loc dim ) - dup rectangle-loc swap rectangle-dim ; +: rect-bounds ( rect -- loc dim ) + dup rect-loc swap rect-dim ; -: shape-extent ( shape -- loc dim ) - dup rectangle-loc dup rot rectangle-dim v+ ; +: rect-extent ( rect -- loc dim ) + dup rect-loc dup rot rect-dim v+ ; -: screen-bounds ( shape -- rect ) - shape-bounds >r origin get v+ r> ; +: screen-loc ( rect -- loc ) + rect-loc origin get v+ ; + +: screen-bounds ( rect -- rect ) + dup screen-loc swap rect-dim ; M: rectangle inside? ( loc rect -- ? ) - screen-bounds shape-bounds { 1 1 1 } v- { 0 0 0 } vmax + screen-bounds rect-bounds { 1 1 1 } v- { 0 0 0 } vmax >r v- { 0 0 0 } r> vbetween? conjunction ; -: intersect ( shape shape -- rect ) - >r shape-extent r> shape-extent - swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax - ; +: intersect ( rect rect -- rect ) + >r rect-extent r> rect-extent swapd vmin >r vmax dup r> + swap v- { 0 0 0 } vmax ; + +: intersects? ( rect rect -- ? ) + >r rect-extent r> rect-extent swapd vmin >r vmax r> v- + [ 0 < ] contains? ; ! A gadget is a rectangle, a paint, a mapping of gestures to ! actions, and a reference to the gadget's parent. @@ -39,7 +45,7 @@ TUPLE: gadget : gadget-child gadget-children first ; C: gadget ( -- gadget ) - { 0 0 0 } dup over set-delegate + { 0 0 0 } dup over set-delegate t over set-gadget-visible? ; DEFER: add-invalid @@ -67,12 +73,12 @@ DEFER: add-invalid dup add-invalid (relayout-down) ; : set-gadget-dim ( dim gadget -- ) - 2dup rectangle-dim = - [ 2drop ] [ [ set-rectangle-dim ] keep relayout-down ] ifte ; + 2dup rect-dim = + [ 2drop ] [ [ set-rect-dim ] keep relayout-down ] ifte ; GENERIC: pref-dim ( gadget -- dim ) -M: gadget pref-dim rectangle-dim ; +M: gadget pref-dim rect-dim ; GENERIC: layout* ( gadget -- ) @@ -91,3 +97,25 @@ M: gadget focusable-child* drop t ; : focusable-child ( gadget -- gadget ) dup focusable-child* dup t = [ drop ] [ nip focusable-child ] ifte ; + +GENERIC: pick-up* ( point gadget -- gadget ) + +: pick-up-list ( point gadgets -- gadget ) + [ + dup gadget-visible? [ inside? ] [ 2drop f ] ifte + ] find-with nip ; + +M: gadget pick-up* ( point gadget -- gadget ) + gadget-children pick-up-list ; + +: pick-up ( point gadget -- gadget ) + #! The logic is thus. If the point is definately outside the + #! box, return f. Otherwise, see if the point is contained + #! in any subgadget. If not, see if it is contained in the + #! box delegate. + dup gadget-visible? >r 2dup inside? r> drop [ + [ rect-loc v- ] keep 2dup + pick-up* [ pick-up ] [ nip ] ?ifte + ] [ + 2drop f + ] ifte ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 5ae0926f8d..7921a601aa 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -4,23 +4,6 @@ IN: gadgets USING: alien generic io kernel lists math matrices namespaces prettyprint sdl sequences vectors ; -: (pick-up) ( point gadget -- gadget ) - gadget-children reverse-slice [ - dup gadget-visible? [ inside? ] [ 2drop f ] ifte - ] find-with nip ; - -: pick-up ( point gadget -- gadget ) - #! The logic is thus. If the point is definately outside the - #! box, return f. Otherwise, see if the point is contained - #! in any subgadget. If not, see if it is contained in the - #! box delegate. - dup gadget-visible? >r 2dup inside? r> drop [ - [ rectangle-loc v- ] keep 2dup - (pick-up) [ pick-up ] [ nip ] ?ifte - ] [ - 2drop f - ] ifte ; - ! The hand is a special gadget that holds mouse position and ! mouse button click state. The hand's parent is the world, but ! it is special in that the world does not list it as part of @@ -72,13 +55,13 @@ C: hand ( world -- hand ) : move-hand ( loc hand -- ) dup hand-gadget parents-down >r - 2dup set-rectangle-loc + 2dup set-rect-loc [ >r world get pick-up r> set-hand-gadget ] keep dup hand-gadget parents-down r> hand-gestures ; : update-hand ( hand -- ) #! Called when a gadget is removed or added. - dup rectangle-loc swap move-hand ; + dup rect-loc swap move-hand ; : focus-gestures ( new old -- ) drop-prefix diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 776d4169de..cd48563562 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -55,7 +55,7 @@ sequences vectors ; : screen-loc ( gadget -- point ) #! The position of the gadget on the screen. - parents-up { 0 0 0 } [ rectangle-loc v+ ] reduce ; + parents-up { 0 0 0 } [ rect-loc v+ ] reduce ; : relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ; diff --git a/library/ui/incremental.factor b/library/ui/incremental.factor index 038ded5bc8..b1711ef814 100644 --- a/library/ui/incremental.factor +++ b/library/ui/incremental.factor @@ -24,7 +24,7 @@ M: incremental layout* drop ; : next-cursor ( gadget incremental -- cursor ) [ - swap rectangle-dim swap incremental-cursor + swap rect-dim swap incremental-cursor 2dup v+ >r vmax r> ] keep pack-vector set-axis ; @@ -33,10 +33,10 @@ M: incremental layout* drop ; : incremental-loc ( gadget incremental -- ) dup incremental-cursor swap pack-vector v* - swap set-rectangle-loc ; + swap set-rect-loc ; : prefer-incremental ( gadget -- ) - dup pref-dim over set-rectangle-dim layout ; + dup pref-dim over set-rect-dim layout ; : add-incremental ( gadget incremental -- ) 2dup (add-gadget) diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index f1cbf27f3f..2035c25592 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -27,7 +27,7 @@ TUPLE: pack align fill vector ; : packed-dim-2 ( gadget sizes -- list ) [ - over rectangle-dim { 1 1 1 } vmax over v- + over rect-dim { 1 1 1 } vmax over v- rot pack-fill v*n v+ ] map-with ; @@ -42,9 +42,9 @@ TUPLE: pack align fill vector ; { 0 0 0 } [ v+ ] accumulate ; : packed-loc-2 ( gadget sizes -- seq ) - >r dup rectangle-dim { 1 1 1 } vmax over r> + >r dup rect-dim { 1 1 1 } vmax over r> packed-dim-2 [ v- ] map-with - >r dup pack-align swap rectangle-dim { 1 1 1 } vmax r> + >r dup pack-align swap rect-dim { 1 1 1 } vmax r> [ >r 2dup r> v- n*v ] map 2nip ; : (packed-locs) ( gadget sizes -- seq ) @@ -52,7 +52,7 @@ TUPLE: pack align fill vector ; : packed-locs ( gadget sizes -- ) over gadget-children >r (packed-locs) r> - [ set-rectangle-loc ] 2each ; + [ set-rect-loc ] 2each ; : packed-layout ( gadget sizes -- ) 2dup packed-locs packed-dims ; @@ -83,6 +83,24 @@ M: pack pref-dim ( pack -- dim ) M: pack layout* ( pack -- ) dup pref-dims packed-layout ; -: ( list -- gadget ) +: pick-up-fast ( axis point gadgets -- gadget ) + [ rect-loc v- over v. ] binsearch* nip ; + +M: pack pick-up* ( point pack -- gadget ) + dup pack-vector pick rot gadget-children + pick-up-fast tuck inside? [ drop f ] unless ; + +! M: pack visible-children* ( rect gadget -- list ) +! gadget-children [ rect-loc origin get v+ intersects? ] subset-with ; + +TUPLE: stack ; + +C: stack ( -- gadget ) #! A stack lays out all its children on top of each other. - 0 1 { 0 0 1 } swap [ over add-gadget ] each ; + 0 1 { 0 0 1 } over set-delegate ; + +M: stack pick-up* ( point stack -- gadget ) + gadget-children reverse-slice pick-up-list ; + +M: stack visible-children* ( rect gadget -- list ) + nip gadget-children ; diff --git a/library/ui/load.factor b/library/ui/load.factor index 706d38a22f..b996162deb 100644 --- a/library/ui/load.factor +++ b/library/ui/load.factor @@ -10,7 +10,6 @@ USING: kernel parser sequences io ; "/library/ui/borders.factor" "/library/ui/frames.factor" "/library/ui/world.factor" - "/library/ui/timer.factor" "/library/ui/hand.factor" "/library/ui/labels.factor" "/library/ui/buttons.factor" diff --git a/library/ui/menus.factor b/library/ui/menus.factor index 6eeb2a5c56..5529c802d1 100644 --- a/library/ui/menus.factor +++ b/library/ui/menus.factor @@ -4,7 +4,7 @@ IN: gadgets USING: generic kernel lists math namespaces sequences ; : show-menu ( menu -- ) - hand screen-loc over set-rectangle-loc show-glass ; + hand screen-loc over set-rect-loc show-glass ; : menu-item-border ( child -- border ) { 1 1 0 } ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 4ec8663e51..d0bc992ab1 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -7,32 +7,35 @@ namespaces sdl sequences strings styles vectors ; SYMBOL: clip : >sdl-rect ( rectangle -- sdlrect ) - [ rectangle-loc 2unseq ] keep rectangle-dim 2unseq make-rect ; + [ rect-loc 2unseq ] keep rect-dim 2unseq make-rect ; -: set-clip ( rect -- ? ) +: set-clip ( rect -- ) #! The top/left corner of the clip rectangle is the location #! of the gadget on the screen. The bottom/right is the - #! intersected clip rectangle. Return f if the clip region - #! is an empty region. - surface get swap >sdl-rect SDL_SetClipRect ; + #! intersected clip rectangle. + surface get swap >sdl-rect SDL_SetClipRect drop ; -: with-clip ( shape quot -- ) - #! All drawing done inside the quotation is clipped to the - #! shape's bounds. - [ - >r screen-bounds clip [ intersect dup ] change set-clip - [ r> call ] [ r> 2drop ] ifte - ] with-scope ; inline +GENERIC: visible-children* ( rect gadget -- list ) + +M: gadget visible-children* ( rect gadget -- list ) + gadget-children [ screen-bounds intersects? ] subset-with ; + +: visible-children ( gadget -- list ) + clip get swap visible-children* ; GENERIC: draw-gadget* ( gadget -- ) +: translate&clip ( gadget -- ) + screen-bounds dup rect-loc origin set + clip [ intersect dup ] change ( set-clip ) drop ; + : draw-gadget ( gadget -- ) dup gadget-visible? [ dup [ - dup rectangle-loc origin [ v+ ] change + translate&clip dup draw-gadget* - gadget-children [ draw-gadget ] each - ] with-clip + visible-children [ draw-gadget ] each + ] with-scope ] [ drop ] ifte ; : paint-prop* ( gadget key -- value ) @@ -73,14 +76,15 @@ M: f draw-boundary 2drop ; TUPLE: solid ; : rect>screen ( shape -- x1 y1 x2 y2 ) - >r origin get dup r> rectangle-dim v+ >r 2unseq r> 2unseq ; + >r origin get dup r> rect-dim v+ + >r 2unseq r> 2unseq >r 1 - r> 1 - ; ! Solid pen M: solid draw-interior drop >r surface get r> [ rect>screen ] keep bg rgb boxColor ; M: solid draw-boundary - drop >r surface get r> [ rect>screen >r 1 - r> 1 - ] keep + drop >r surface get r> [ rect>screen ] keep fg rgb rectangleColor ; ! Gradient pen @@ -113,7 +117,7 @@ TUPLE: gradient vector from to ; dup first [ 3dup gradient-y ] repeat 2drop ; M: gradient draw-interior ( gadget gradient -- ) - swap rectangle-dim { 1 1 1 } vmax + swap rect-dim { 1 1 1 } vmax over gradient-vector { 1 0 0 } = [ horiz-gradient ] [ vert-gradient ] ifte ; @@ -144,7 +148,7 @@ SYMBOL: bevel-2 M: bevel draw-boundary ( gadget boundary -- ) #! Ugly code. bevel-width [ - >r origin get over rectangle-dim over v+ r> + >r origin get over rect-dim over v+ r> { 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r> rot draw-bevel ] each-with ; diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index c2c64d205f..9ddec29cb9 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -16,7 +16,7 @@ TUPLE: scroller viewport x y ; : viewport-dim gadget-child pref-dim ; : fix-scroll ( origin viewport -- origin ) - dup rectangle-dim swap viewport-dim v- vmax { 0 0 0 } vmin ; + dup rect-dim swap viewport-dim v- vmax { 0 0 0 } vmin ; : scroll-viewport ( origin viewport -- ) [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ; @@ -41,13 +41,13 @@ M: viewport pref-dim gadget-child pref-dim ; M: viewport layout* ( viewport -- ) dup gadget-child dup prefer >r dup viewport-origin* swap fix-scroll r> - set-rectangle-loc ; + set-rect-loc ; M: viewport focusable-child* ( viewport -- gadget ) gadget-child ; : visible-portion ( viewport -- vector ) - dup rectangle-dim { 1 1 1 } vmax + dup rect-dim { 1 1 1 } vmax swap viewport-dim { 1 1 1 } vmax v/ { 1 1 1 } vmin ; @@ -117,13 +117,13 @@ C: slider ( vector -- slider ) : slider-dim { 12 12 12 } ; : thumb-dim ( slider -- h ) - [ rectangle-dim dup ] keep >thumb slider-dim vmax vmin ; + [ rect-dim dup ] keep >thumb slider-dim vmax vmin ; M: slider pref-dim drop slider-dim ; M: slider layout* ( slider -- ) dup thumb-loc over slider-vector v* - over slider-thumb set-rectangle-loc + over slider-thumb set-rect-loc dup thumb-dim over slider-vector v* slider-dim vmax swap slider-thumb set-gadget-dim ; diff --git a/library/ui/splitters.factor b/library/ui/splitters.factor index 9cbcb22e84..46aa1d062a 100644 --- a/library/ui/splitters.factor +++ b/library/ui/splitters.factor @@ -17,7 +17,7 @@ TUPLE: splitter split ; : divider-motion ( splitter -- ) dup hand>split - over rectangle-dim { 1 1 1 } vmax v/ over pack-vector v. + over rect-dim { 1 1 1 } vmax v/ over pack-vector v. 0 max 1 min over set-splitter-split relayout ; : divider-actions ( thumb -- ) @@ -45,14 +45,14 @@ C: splitter ( first second split vector -- splitter ) { 1 0 0 } ; : splitter-part ( splitter -- vec ) - dup splitter-split swap rectangle-dim + dup splitter-split swap rect-dim n*v divider-size 1/2 v*n v- ; : splitter-layout ( splitter -- { a b c } ) [ dup splitter-part , divider-size , - dup rectangle-dim divider-size v- swap splitter-part v- , + dup rect-dim divider-size v- swap splitter-part v- , ] make-vector ; M: splitter layout* ( splitter -- ) diff --git a/library/ui/ui.factor b/library/ui/ui.factor index de03cc068d..8cb3974ed2 100644 --- a/library/ui/ui.factor +++ b/library/ui/ui.factor @@ -61,7 +61,7 @@ IN: shells #! dimensions. ttf-init ?init-world - world get rectangle-dim 2unseq 0 SDL_RESIZABLE [ + world get rect-dim 2unseq 0 SDL_RESIZABLE [ [ "Factor " version append dup SDL_WM_SetCaption start-world diff --git a/library/ui/world.factor b/library/ui/world.factor index 2cfb9dbe75..265d10520f 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -16,7 +16,7 @@ DEFER: update-hand DEFER: do-timers C: world ( -- world ) - f over set-delegate + over set-delegate t over set-gadget-root? dup over set-world-hand ; @@ -47,7 +47,7 @@ M: world inside? ( point world -- ? ) 2drop t ; : draw-world ( world -- ) [ - { 0 0 0 } width get height get 0 3vector clip set + { 0 0 0 } width get height get 0 3vector clip set draw-gadget ] with-surface ;