: rgb ( [ r g b ] -- n )
3unlist
255
- swap 8 shift bitor
- swap 16 shift bitor
- swap 24 shift bitor ;
+ swap >fixnum 8 shift bitor
+ swap >fixnum 16 shift bitor
+ swap >fixnum 24 shift bitor ;
: make-color ( r g b -- color )
#! Make an SDL_Color struct. This will go away soon in favor
--- /dev/null
+IN: temporary
+USING: gadgets namespaces styles test ;
+
+[
+ 0 x set
+ 0 y set
+
+ [ [ 255 0 0 ] ] [ { 1 0 0 } red green <gradient> 0 gradient-color ] unit-test
+ [ [ 0 255 0 ] ] [ { 1 0 0 } red green <gradient> 1 gradient-color ] unit-test
+
+ [ 0 100 0 [ 255 0 0 ] ]
+ [ { 0 1 0 } red green <gradient> { 100 200 0 } 0 (gradient-x) ] unit-test
+
+ [ 0 100 100 [ 255/2 255/2 0 ] ]
+ [ { 0 1 0 } red green <gradient> { 100 200 0 } 100 (gradient-x) ] unit-test
+
+ [ 0 0 200 [ 255 0 0 ] ]
+ [ { 1 0 0 } red green <gradient> { 100 200 0 } 0 (gradient-y) ] unit-test
+
+ [ 50 0 200 [ 255/2 255/2 0 ] ]
+ [ { 1 0 0 } red green <gradient> { 100 200 0 } 50 (gradient-y) ] unit-test
+] with-scope
"crashes" "sbuf" "threads" "parsing-word"
"inference" "interpreter"
"alien"
- "gadgets/line-editor" "gadgets/rectangles" "memory"
+ "gadgets/line-editor" "gadgets/rectangles"
+ "gadgets/gradients" "memory"
"redefine" "annotate" "sequences" "binary" "inspector"
] run-tests ;
dup editor-caret swap caret-loc swap set-shape-loc ;
M: editor draw-gadget* ( editor -- )
- dup editor-text over [ draw-string ] with-trans ;
+ dup editor-text draw-string ;
dup label-text label-size ;
M: label draw-gadget* ( label -- )
- dup label-text over [ draw-string ] with-trans ;
+ dup label-text draw-string ;
: draw-gadget ( gadget -- )
dup gadget-visible? [
dup [
- dup draw-gadget* dup [
+ dup [
+ dup draw-gadget*
gadget-children [ draw-gadget ] each
] with-trans
] with-clip
dup rollover paint-prop rollover-bg background ?
] ifte paint-prop ;
-: filled-rect
- >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
-
-: etched-rect
- >r surface get r> [ rect>screen >r 1 - r> 1 - ] keep
- fg rgb rectangleColor ;
-
! Paint properties
SYMBOL: interior
SYMBOL: boundary
TUPLE: solid ;
+: rect>screen ( shape -- x1 y1 x2 y2 )
+ >r x get y get r> dup shape-w swap shape-h
+ >r pick + r> pick + ;
+
M: solid draw-interior
drop >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
drop >r surface get r> [ rect>screen >r 1 - r> 1 - ] keep
fg rgb rectangleColor ;
+TUPLE: gradient vector from to ;
+
+: gradient-color ( gradient prop -- color )
+ over gradient-from 1 pick - v*n
+ >r swap gradient-to n*v r> v+ ;
+
+: (gradient-x) ( gradient dim y -- x1 x2 y color )
+ dup pick second / >r rot r> gradient-color >r
+ >r >r x get r> first x get + r> y get + r> ;
+
+: gradient-x ( gradient dim y -- )
+ >r >r >r surface get r> r> r> (gradient-x) rgb hlineColor ;
+
+: vert-gradient ( gradient dim -- )
+ dup second [ 3dup gradient-x ] repeat 2drop ;
+
+: (gradient-y) ( gradient dim x -- x y1 y2 color )
+ dup pick first / >r rot r> gradient-color
+ >r x get + y get rot second y get + r> ;
+
+: gradient-y ( gradient dim x -- )
+ >r >r >r surface get r> r> r> (gradient-y) rgb vlineColor ;
+
+: horiz-gradient ( gradient dim -- )
+ dup first [ 3dup gradient-y ] repeat 2drop ;
+
+M: gradient draw-interior ( gadget gradient -- )
+ swap shape-dim { 1 1 1 } vmax
+ over gradient-vector { 1 0 0 } =
+ [ horiz-gradient ] [ vert-gradient ] ifte ;
+
M: gadget draw-gadget* ( gadget -- )
dup
dup interior paint-prop* draw-interior
>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 + ;
2drop
] [
>r [ gadget-font ] keep r> swap
- [ fg 3unlist make-color ] keep
- bg 3unlist make-color
- TTF_RenderUNICODE_Shaded
+ fg 3unlist make-color
+ TTF_RenderUNICODE_Blended
[ >r x get y get r> draw-surface ] keep
SDL_FreeSurface
] ifte ;