! 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
--- /dev/null
+IN: temporary
+USING: kernel line-editor namespaces sequences strings test ;
+
+<line-editor> "editor" set
+
+[ "Hello world" ] [
+ "Hello world" 0 "editor" get [ line-insert ] bind
+ "editor" get [ line-text get ] bind
+] unit-test
+
+[ t ] [
+ "editor" get [ caret get ] bind
+ "Hello world" length =
+] unit-test
+
+[ "Hello, crazy world" ] [
+ "editor" get [ 0 caret set ] bind
+ ", crazy" 5 "editor" get [ line-insert ] bind
+ "editor" get [ line-text get ] bind
+] unit-test
+
+[ 0 ] [ "editor" get [ caret get ] bind ] unit-test
+
+[ "Hello, crazy world" ] [
+ "editor" get [ 5 caret set "Hello world" line-text set ] bind
+ ", crazy" 5 "editor" get [ line-insert ] bind
+ "editor" get [ line-text get ] bind
+] unit-test
+
+[ "Hello, crazy" ] [
+ "editor" get [ caret get line-text get head ] bind
+] unit-test
+
+[ 0 ]
+[
+ [
+ 0 caret set
+ 3 2 caret-remove
+ caret get
+ ] with-scope
+] unit-test
+
+[ 3 ]
+[
+ [
+ 4 caret set
+ 3 6 caret-remove
+ caret get
+ ] with-scope
+] unit-test
+
+[ 5 ]
+[
+ [
+ 8 caret set
+ 3 3 caret-remove
+ caret get
+ ] with-scope
+] unit-test
+
+[ "Hellorld" ]
+[
+ "editor" get [ 0 caret set "Hello world" line-text set ] bind
+ 4 3 "editor" get [ line-remove ] bind
+ "editor" get [ line-text get ] bind
+] unit-test
+++ /dev/null
-IN: temporary
-USING: kernel line-editor namespaces sequences strings test ;
-
-<line-editor> "editor" set
-
-[ "Hello world" ] [
- "Hello world" 0 "editor" get [ line-insert ] bind
- "editor" get [ line-text get ] bind
-] unit-test
-
-[ t ] [
- "editor" get [ caret get ] bind
- "Hello world" length =
-] unit-test
-
-[ "Hello, crazy world" ] [
- "editor" get [ 0 caret set ] bind
- ", crazy" 5 "editor" get [ line-insert ] bind
- "editor" get [ line-text get ] bind
-] unit-test
-
-[ 0 ] [ "editor" get [ caret get ] bind ] unit-test
-
-[ "Hello, crazy world" ] [
- "editor" get [ 5 caret set "Hello world" line-text set ] bind
- ", crazy" 5 "editor" get [ line-insert ] bind
- "editor" get [ line-text get ] bind
-] unit-test
-
-[ "Hello, crazy" ] [
- "editor" get [ caret get line-text get head ] bind
-] unit-test
-
-[ 0 ]
-[
- [
- 0 caret set
- 3 2 caret-remove
- caret get
- ] with-scope
-] unit-test
-
-[ 3 ]
-[
- [
- 4 caret set
- 3 6 caret-remove
- caret get
- ] with-scope
-] unit-test
-
-[ 5 ]
-[
- [
- 8 caret set
- 3 3 caret-remove
- caret get
- ] with-scope
-] unit-test
-
-[ "Hellorld" ]
-[
- "editor" get [ 0 caret set "Hello world" line-text set ] bind
- 4 3 "editor" get [ line-remove ] bind
- "editor" get [ line-text get ] bind
-] unit-test
[ over [ add-gadget ] [ 2drop ] ifte ] keep ;
: line-border ( child -- border )
- { 0 0 0 } dup <etched-rect> <gadget> { 5 5 0 } <border> ;
+ <etched-gadget> { 5 5 0 } <border> ;
: layout-border-loc ( border -- )
dup border-size swap gadget-child set-shape-loc ;
+++ /dev/null
-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 ] ;
<plain-gadget> dup red background set-paint-prop ;
C: editor ( text -- )
- <empty-gadget> over set-delegate
+ <gadget> over set-delegate
[ <line-editor> swap set-editor-line ] keep
[ <caret> swap set-editor-caret ] keep
[ set-editor-text ] keep
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 ;
dup frame-bottom unparent 2dup set-frame-bottom add-gadget ;
C: frame ( -- frame )
- [ <empty-gadget> swap set-delegate ] keep
- [ <empty-gadget> swap set-frame-center ] keep
- [ <empty-gadget> swap set-frame-left ] keep
- [ <empty-gadget> swap set-frame-right ] keep
- [ <empty-gadget> swap set-frame-top ] keep
- [ <empty-gadget> swap set-frame-bottom ] keep ;
+ [ <gadget> swap set-delegate ] keep
+ [ <gadget> swap set-frame-center ] keep
+ [ <gadget> swap set-frame-left ] keep
+ [ <gadget> swap set-frame-right ] keep
+ [ <gadget> swap set-frame-top ] keep
+ [ <gadget> swap set-frame-bottom ] keep ;
: frame-major ( frame -- list )
[
: gadget-child gadget-children car ;
-C: gadget ( shape -- gadget )
- [ set-delegate ] keep
+C: gadget ( -- gadget )
+ { 0 0 0 } dup <rectangle> over set-delegate
<namespace> over set-gadget-paint
<namespace> over set-gadget-gestures ;
-: <empty-gadget> ( -- gadget )
- { 0 0 0 } dup <rectangle> <gadget> ;
+TUPLE: plain-gadget ;
-: <plain-gadget> ( -- gadget )
- { 0 0 0 } dup <plain-rect> <gadget> ;
+C: plain-gadget <gadget> over set-delegate ;
+
+TUPLE: etched-gadget ;
+
+C: etched-gadget <gadget> over set-delegate ;
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 ;
TUPLE: hand click-loc click-rel clicked buttons gadget focus ;
C: hand ( world -- hand )
- <empty-gadget> over set-delegate
+ <gadget> over set-delegate
[ set-gadget-parent ] 2keep
[ set-hand-gadget ] keep ;
#! 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- ;
[ [ clear print-banner listener ] with-stream ] in-thread
- request-focus
+ dup request-focus
+
+ pane set
] bind ;
SYMBOL: first-time
TUPLE: label text ;
C: label ( text -- label )
- <empty-gadget> over set-delegate [ set-label-text ] keep ;
+ <gadget> over set-delegate [ set-label-text ] keep ;
: label-size ( gadget text -- dim )
>r gadget-font r> size-string 0 3vector ;
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 ;
#! 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 ;
#! align: 0 left aligns, 1/2 center, 1 right.
#! gap: between each child.
#! fill: 0 leaves default width, 1 fills to pack width.
- [ <empty-gadget> swap set-delegate ] keep
+ [ <gadget> swap set-delegate ] keep
[ set-pack-vector ] keep
[ set-pack-fill ] keep
[ set-pack-align ] keep ;
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"
! 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
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 ;
+++ /dev/null
-! 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> <rectangle> ;
-
-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
- <rectangle> ;
-
-: 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 <rectangle> 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 <rectangle> 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 <rectangle> r> set-delegate ] keep ;
-
-M: etched-rect draw-shape ( rect -- )
- >r surface get r> 2dup plain-rect hollow-rect ;
[ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
C: viewport ( content -- viewport )
- <empty-gadget> over set-delegate
+ <gadget> over set-delegate
t over set-gadget-root?
[ add-gadget ] keep
{ 0 0 0 } over set-viewport-origin ;
: 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.
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> <rectangle> ;
+
+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
+ <rectangle> ;
+
+: rect>screen ( shape -- x1 y1 x2 y2 )
+ [ shape-x x get + ] keep
+ [ shape-y y get + ] keep
+ [ shape-w pick + ] keep
+ shape-h pick + ;
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
: show-glass ( gadget -- )
hide-glass
- <empty-gadget> dup
+ <gadget> dup
world get 2dup add-gadget set-world-glass
dupd add-gadget prefer ;
: draw-world ( world -- )
[
dup
- { 0 0 0 }
- width get height get 0 3vector <rectangle>
- clip set-paint-prop
+ { 0 0 0 } width get height get 0 3vector <rectangle> clip set
draw-gadget
] with-surface ;
projects / factor.git / commitdiff