diff --git a/library/styles.factor b/library/styles.factor index 61d69d5969..0f95ba97b0 100644 --- a/library/styles.factor +++ b/library/styles.factor @@ -1,25 +1,21 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: styles -USING: kernel namespaces ; -! Colors are lists of three integers, 0..255. +! Colors are RGB triples. +: black [ 0 0 0 ] ; +: gray [ 128 128 128 ] ; +: white [ 255 255 255 ] ; +: red [ 255 0 0 ] ; +: green [ 0 255 0 ] ; +: blue [ 0 0 255 ] ; + SYMBOL: foreground ! Used for text and outline shapes. SYMBOL: background ! Used for filled shapes. SYMBOL: rollover-bg SYMBOL: rollover SYMBOL: reverse-video -: fg ( -- color ) - reverse-video get background foreground ? get ; - -: bg ( -- color ) - reverse-video get [ - foreground - ] [ - rollover get rollover-bg background ? - ] ifte get ; - SYMBOL: font SYMBOL: font-size SYMBOL: font-style diff --git a/library/test/line-editor.factor b/library/test/gadgets/line-editor.factor similarity index 100% rename from library/test/line-editor.factor rename to library/test/gadgets/line-editor.factor diff --git a/library/ui/borders.factor b/library/ui/borders.factor index e7d0c37886..e19ac14197 100644 --- a/library/ui/borders.factor +++ b/library/ui/borders.factor @@ -12,7 +12,7 @@ C: border ( child delegate size -- border ) [ over [ add-gadget ] [ 2drop ] ifte ] keep ; : line-border ( child -- border ) - { 0 0 0 } dup { 5 5 0 } ; + { 5 5 0 } ; : layout-border-loc ( border -- ) dup border-size swap gadget-child set-shape-loc ; diff --git a/library/ui/colors.factor b/library/ui/colors.factor deleted file mode 100644 index 9ba8bac654..0000000000 --- a/library/ui/colors.factor +++ /dev/null @@ -1,8 +0,0 @@ -IN: gadgets - -: black [ 0 0 0 ] ; -: gray [ 128 128 128 ] ; -: white [ 255 255 255 ] ; -: red [ 255 0 0 ] ; -: green [ 0 255 0 ] ; -: blue [ 0 0 255 ] ; diff --git a/library/ui/editors.factor b/library/ui/editors.factor index a0ffd0dd5e..f4027a4af8 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -67,7 +67,7 @@ TUPLE: editor line caret ; dup red background set-paint-prop ; C: editor ( text -- ) - over set-delegate + over set-delegate [ swap set-editor-line ] keep [ swap set-editor-caret ] keep [ set-editor-text ] keep @@ -93,6 +93,5 @@ M: editor layout* ( editor -- ) dup editor-caret over caret-dim swap set-gadget-dim dup editor-caret swap caret-loc swap set-shape-loc ; -M: editor draw-shape ( editor -- ) - [ dup gadget-font swap editor-text ] keep - [ draw-string ] with-trans ; +M: editor draw-gadget* ( editor -- ) + dup editor-text over [ draw-string ] with-trans ; diff --git a/library/ui/frames.factor b/library/ui/frames.factor index e8ab8af6d1..6dc1dbba94 100644 --- a/library/ui/frames.factor +++ b/library/ui/frames.factor @@ -20,12 +20,12 @@ TUPLE: frame left right top bottom center ; dup frame-bottom unparent 2dup set-frame-bottom add-gadget ; C: frame ( -- frame ) - [ swap set-delegate ] keep - [ swap set-frame-center ] keep - [ swap set-frame-left ] keep - [ swap set-frame-right ] keep - [ swap set-frame-top ] keep - [ swap set-frame-bottom ] keep ; + [ swap set-delegate ] keep + [ swap set-frame-center ] keep + [ swap set-frame-left ] keep + [ swap set-frame-right ] keep + [ swap set-frame-top ] keep + [ swap set-frame-bottom ] keep ; : frame-major ( frame -- list ) [ diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 55aae68a33..d369a7fd47 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -11,16 +11,18 @@ TUPLE: gadget paint gestures relayout? root? parent children ; : gadget-child gadget-children car ; -C: gadget ( shape -- gadget ) - [ set-delegate ] keep +C: gadget ( -- gadget ) + { 0 0 0 } dup over set-delegate over set-gadget-paint over set-gadget-gestures ; -: ( -- gadget ) - { 0 0 0 } dup ; +TUPLE: plain-gadget ; -: ( -- gadget ) - { 0 0 0 } dup ; +C: plain-gadget over set-delegate ; + +TUPLE: etched-gadget ; + +C: etched-gadget over set-delegate ; DEFER: add-invalid @@ -50,20 +52,6 @@ DEFER: add-invalid 2dup shape-dim = [ 2drop ] [ [ set-shape-dim ] keep relayout-down ] ifte ; -: paint-prop ( gadget key -- value ) - over [ - dup pick gadget-paint hash* dup [ - 2nip cdr - ] [ - drop >r gadget-parent r> paint-prop - ] ?ifte - ] [ - 2drop f - ] ifte ; - -: set-paint-prop ( gadget value key -- ) - rot gadget-paint set-hash ; - GENERIC: pref-dim ( gadget -- dim ) M: gadget pref-dim shape-dim ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index ff9530d7b3..033dbc5a29 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -38,7 +38,7 @@ DEFER: pick-up TUPLE: hand click-loc click-rel clicked buttons gadget focus ; C: hand ( world -- hand ) - over set-delegate + over set-delegate [ set-gadget-parent ] 2keep [ set-hand-gadget ] keep ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 6211246f53..df8645c4f9 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -25,35 +25,19 @@ sequences ; #! Add a gadget to a parent gadget. [ (add-gadget) ] keep relayout ; -: (parents) ( gadget -- ) - [ dup gadget-parent (parents) , ] when* ; - : parents ( gadget -- list ) - #! A list of all parents of the gadget, including the - #! gadget itself. - [ (parents) ] make-list ; - -: (each-parent) ( list quot -- ? ) - over [ - over car gadget-paint [ - 2dup >r >r >r cdr r> (each-parent) [ - r> car r> call - ] [ - r> r> 2drop f - ] ifte - ] bind - ] [ - 2drop t - ] ifte ; inline + #! A list of all parents of the gadget, the first element + #! is the gadget itself. + dup [ dup gadget-parent parents cons ] when ; : each-parent ( gadget quot -- ? ) #! Keep executing the quotation on higher and higher #! parents until it returns f. - >r parents r> (each-parent) ; inline + >r parents r> all? ; inline : screen-loc ( gadget -- point ) #! The position of the gadget on the screen. - { 0 0 0 } swap [ shape-loc v+ t ] each-parent drop ; + parents { 0 0 0 } [ shape-loc v+ ] reduce ; : relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ; diff --git a/library/ui/init-world.factor b/library/ui/init-world.factor index ed7ffca7d9..f25abbf797 100644 --- a/library/ui/init-world.factor +++ b/library/ui/init-world.factor @@ -27,7 +27,9 @@ USING: generic io kernel listener math namespaces styles threads ; [ [ clear print-banner listener ] with-stream ] in-thread - request-focus + dup request-focus + + pane set ] bind ; SYMBOL: first-time diff --git a/library/ui/labels.factor b/library/ui/labels.factor index feb0dc1d0b..fc3657be77 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -8,7 +8,7 @@ sequences styles vectors ; TUPLE: label text ; C: label ( text -- label ) - over set-delegate [ set-label-text ] keep ; + over set-delegate [ set-label-text ] keep ; : label-size ( gadget text -- dim ) >r gadget-font r> size-string 0 3vector ; @@ -16,6 +16,5 @@ C: label ( text -- label ) M: label pref-dim ( label -- dim ) dup label-text label-size ; -M: label draw-shape ( label -- ) - [ dup gadget-font swap label-text ] keep - [ draw-string ] with-trans ; +M: label draw-gadget* ( label -- ) + dup label-text over [ draw-string ] with-trans ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 0aaa504a9d..90cfa1467a 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -11,10 +11,8 @@ namespaces sdl sequences ; #! be laid out. dup gadget-relayout? [ f over set-gadget-relayout? - dup gadget-paint [ - dup layout* - gadget-children [ layout ] each - ] bind + dup layout* + gadget-children [ layout ] each ] [ drop ] ifte ; @@ -63,7 +61,7 @@ C: pack ( align fill vector -- pack ) #! align: 0 left aligns, 1/2 center, 1 right. #! gap: between each child. #! fill: 0 leaves default width, 1 fills to pack width. - [ swap set-delegate ] keep + [ swap set-delegate ] keep [ set-pack-vector ] keep [ set-pack-fill ] keep [ set-pack-align ] keep ; diff --git a/library/ui/load.factor b/library/ui/load.factor index 542ec8c80d..913da986a6 100644 --- a/library/ui/load.factor +++ b/library/ui/load.factor @@ -1,8 +1,6 @@ USING: kernel parser sequences io ; [ - "/library/ui/colors.factor" "/library/ui/shapes.factor" - "/library/ui/rectangles.factor" "/library/ui/gadgets.factor" "/library/ui/hierarchy.factor" "/library/ui/paint.factor" diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 201dce36f7..03d4b813d5 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: generic hashtables io kernel lists math matrices -namespaces sdl sequences strings ; +namespaces sdl sequences strings styles ; SYMBOL: clip @@ -26,16 +26,54 @@ SYMBOL: clip r> call ] with-scope ; inline +GENERIC: draw-gadget* ( gadget -- ) + : draw-gadget ( gadget -- ) - #! All drawing done inside draw-shape is done with the - #! gadget's paint. If the gadget does not have any custom - #! paint, just call the quotation. - dup gadget-paint [ - dup [ - [ - dup draw-shape dup [ - gadget-children [ draw-gadget ] each - ] with-trans - ] [ drop ] ifte - ] with-clip - ] bind ; + dup [ + [ + dup draw-gadget* dup [ + gadget-children [ draw-gadget ] each + ] with-trans + ] [ drop ] ifte + ] with-clip ; + +M: gadget draw-gadget* ( gadget -- ) drop ; + +: paint-prop ( gadget key -- value ) + over [ + dup pick gadget-paint hash* dup [ + 2nip cdr + ] [ + drop >r gadget-parent r> paint-prop + ] ?ifte + ] [ + 2drop f + ] ifte ; + +: set-paint-prop ( gadget value key -- ) + rot gadget-paint set-hash ; + +: fg ( gadget -- color ) + dup reverse-video paint-prop + background foreground ? paint-prop ; + +: bg ( gadget -- color ) + dup reverse-video paint-prop [ + foreground + ] [ + dup rollover paint-prop rollover-bg background ? + ] ifte paint-prop ; + +: plain-rect ( shape -- ) + #! Draw a filled rect with the bounds of an arbitrary shape. + [ rect>screen ] keep bg rgb boxColor ; + +M: plain-gadget draw-gadget* ( gadget -- ) + >r surface get r> plain-rect ; + +: hollow-rect ( shape -- ) + #! Draw a hollow rect with the bounds of an arbitrary shape. + [ rect>screen >r 1 - r> 1 - ] keep fg rgb rectangleColor ; + +M: etched-gadget draw-gadget* ( gadget -- ) + >r surface get r> 2dup plain-rect hollow-rect ; diff --git a/library/ui/rectangles.factor b/library/ui/rectangles.factor deleted file mode 100644 index 68b5a7b0ad..0000000000 --- a/library/ui/rectangles.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: gadgets -USING: generic kernel lists math matrices namespaces sdl styles -vectors ; - -TUPLE: rectangle loc dim ; - -M: rectangle shape-loc rectangle-loc ; -M: rectangle set-shape-loc set-rectangle-loc ; - -M: rectangle shape-dim rectangle-dim ; -M: rectangle set-shape-dim set-rectangle-dim ; - -: screen-bounds ( shape -- rect ) - shape-bounds >r origin v+ r> ; - -M: rectangle inside? ( loc rect -- ? ) - screen-bounds shape-bounds { 1 1 1 } v- { 0 0 0 } vmax - >r v- { 0 0 0 } r> vbetween? conj ; - -M: rectangle draw-shape drop ; - -: intersect ( shape shape -- rect ) - >r shape-extent r> shape-extent - swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax - ; - -: rect>screen ( shape -- x1 y1 x2 y2 ) - [ shape-x x get + ] keep - [ shape-y y get + ] keep - [ shape-w pick + ] keep - shape-h pick + ; - -! A rectangle only whose outline is visible. -TUPLE: hollow-rect ; - -C: hollow-rect ( loc dim -- rect ) - [ >r r> set-delegate ] keep ; - -: hollow-rect ( shape -- ) - #! Draw a hollow rect with the bounds of an arbitrary shape. - rect>screen >r 1 - r> 1 - fg rgb rectangleColor ; - -M: hollow-rect draw-shape ( rect -- ) - >r surface get r> hollow-rect ; - -! A rectangle that is filled. -TUPLE: plain-rect ; - -C: plain-rect ( loc dim -- rect ) - [ >r r> set-delegate ] keep ; - -: plain-rect ( shape -- ) - #! Draw a filled rect with the bounds of an arbitrary shape. - rect>screen bg rgb boxColor ; - -M: plain-rect draw-shape ( rect -- ) - >r surface get r> plain-rect ; - -! A rectangle that is filled with the background color and also -! has an outline. -TUPLE: etched-rect ; - -C: etched-rect ( loc dim -- rect ) - [ >r r> set-delegate ] keep ; - -M: etched-rect draw-shape ( rect -- ) - >r surface get r> 2dup plain-rect hollow-rect ; diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 365c95eaa7..1ae0c99868 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -17,7 +17,7 @@ TUPLE: viewport origin ; [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ; C: viewport ( content -- viewport ) - over set-delegate + over set-delegate t over set-gadget-root? [ add-gadget ] keep { 0 0 0 } over set-viewport-origin ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 902508d4b0..aaf06f4711 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -20,8 +20,6 @@ GENERIC: set-shape-dim ( dim shape -- ) : shape-w shape-dim first ; : shape-h shape-dim second ; -GENERIC: draw-shape ( shape -- ) - : with-trans ( shape quot -- ) #! All drawing done inside the quotation is translated #! relative to the shape's origin. @@ -47,3 +45,29 @@ GENERIC: draw-shape ( shape -- ) M: vector shape-loc ; M: vector shape-dim drop { 0 0 0 } ; + +TUPLE: rectangle loc dim ; + +M: rectangle shape-loc rectangle-loc ; +M: rectangle set-shape-loc set-rectangle-loc ; + +M: rectangle shape-dim rectangle-dim ; +M: rectangle set-shape-dim set-rectangle-dim ; + +: screen-bounds ( shape -- rect ) + shape-bounds >r origin v+ r> ; + +M: rectangle inside? ( loc rect -- ? ) + screen-bounds shape-bounds { 1 1 1 } v- { 0 0 0 } vmax + >r v- { 0 0 0 } r> vbetween? conj ; + +: intersect ( shape shape -- rect ) + >r shape-extent r> shape-extent + swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax + ; + +: rect>screen ( shape -- x1 y1 x2 y2 ) + [ shape-x x get + ] keep + [ shape-y y get + ] keep + [ shape-w pick + ] keep + shape-h pick + ; diff --git a/library/ui/text.factor b/library/ui/text.factor index 8ac8674da9..6a268ba59a 100644 --- a/library/ui/text.factor +++ b/library/ui/text.factor @@ -27,11 +27,12 @@ strings styles io ; swap *int swap *int ] ifte ; -: draw-string ( font text -- ) +: draw-string ( gadget text -- ) filter-nulls dup empty? [ 2drop ] [ - fg 3unlist make-color + >r [ gadget-font ] keep r> swap + [ fg 3unlist make-color ] keep bg 3unlist make-color TTF_RenderUNICODE_Shaded [ >r x get y get r> draw-surface ] keep diff --git a/library/ui/world.factor b/library/ui/world.factor index 711cd15a8c..db3454e060 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -36,7 +36,7 @@ C: world ( -- world ) : show-glass ( gadget -- ) hide-glass - dup + dup world get 2dup add-gadget set-world-glass dupd add-gadget prefer ; @@ -47,9 +47,7 @@ M: world inside? ( point world -- ? ) 2drop t ; : draw-world ( world -- ) [ dup - { 0 0 0 } - width get height get 0 3vector - clip set-paint-prop + { 0 0 0 } width get height get 0 3vector clip set draw-gadget ] with-surface ;