"/library/ui/hand.factor"\r
"/library/ui/world.factor"\r
"/library/ui/labels.factor"\r
- "/library/ui/piles.factor"\r
+ "/library/ui/layouts.factor"\r
"/library/ui/events.factor"\r
] [\r
dup print\r
"surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ;
: TTF_RenderText_Blended ( font text fg -- surface )
- "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" ] alien-invoke ;
+ "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "char*" "int" ] alien-invoke ;
: TTF_RenderGlyph_Blended ( font text fg -- surface )
"surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ;
SDL_LockSurface
] when drop ;
-: draw-string ( x y font text fg bg -- width )
- pick str-length 0 = [
- 2drop 2drop 2drop 0
+: draw-string ( x y font text fg -- width )
+ over str-length 0 = [
+ 2drop 3drop 0
] [
- TTF_RenderText_Shaded
+ TTF_RenderText_Blended
[ draw-surface ] keep
[ surface-w ] keep
SDL_FreeSurface
[
2000 x set
2000 y set
- 2030 2040 rect> 10 20 300 400 <rect> inside?
+ 2030 2040 <point> 10 20 300 400 <rectangle> inside?
] with-scope
] unit-test
[ f ] [
[
2000 x set
2000 y set
- 2500 2040 rect> 10 20 300 400 <rect> inside?
+ 2500 2040 <point> 10 20 300 400 <rectangle> inside?
] with-scope
] unit-test
[ t ] [
[
-10 x set
-20 y set
- 0 0 rect> 10 20 300 400 <rect> inside?
+ 0 0 <point> 10 20 300 400 <rectangle> inside?
] with-scope
] unit-test
[ 11 11 41 41 ] [
[
1 x set
1 y set
- 10 10 30 30 <rect> <gadget> shape>screen
+ 10 10 30 30 <rectangle> <gadget> shape>screen
] with-scope
] bind
] unit-test
[ t ] [
default-paint [
- 0 0 rect> -10 -10 20 20 <rect> <gadget> [ pick-up ] keep =
+ 0 0 <point> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
] bind
] unit-test
: funny-rect ( x -- rect )
- 10 10 30 <rect> <gadget>
- dup [ 255 0 0 ] color set-paint-property
- dup t filled set-paint-property ;
+ 10 10 30 <rectangle> <gadget>
+ dup [ 255 0 0 ] color set-paint-property ;
[ f ] [
default-paint [
- 35 0 rect>
+ 35 0 <point>
[ 10 30 50 70 ] [ funny-rect ] map
pick-up
] bind
] unit-test
+
+[ 1 3 2 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y1 ] unit-test
+[ 1 3 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y2 ] unit-test
+[ 1 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/y1/y2 ] unit-test
+[ 3 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x2/y1/y2 ] unit-test
M: box gadget-children box-children ;
-M: general-list draw ( list -- )
- [ draw ] each ;
-
-M: box draw ( box -- )
- dup [
- dup [
- dup
- box-delegate draw
- box-children draw
- ] with-gadget
- ] with-translation ;
+M: box draw-shape ( box -- )
+ dup box-delegate draw-gadget
+ dup [ box-children [ draw-gadget ] each ] with-translation ;
M: general-list pick-up* ( point list -- gadget )
dup [
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
world get redraw ;
-: button-event-pos ( event -- #{ x y }# )
- dup button-event-x swap button-event-y rect> ;
+: button-event-pos ( event -- point )
+ dup button-event-x swap button-event-y <point> ;
M: button-down-event handle-event ( event -- )
dup button-event-pos my-hand set-hand-click-pos
: set-action ( gadget quot gesture -- )
rot gadget-gestures set-hash ;
-: with-gadget ( gadget quot -- )
- #! All drawing done inside the quotation is done with the
+: 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.
- >r gadget-paint r> bind ;
-
-M: gadget draw ( gadget -- ) drop ;
+ dup gadget-paint [ draw-shape ] bind ;
M: gadget pick-up* inside? ;
gadget-parent [ relayout ] when* ;
: move-gadget ( x y gadget -- )
- [ move-shape ] keep
- [ set-gadget-delegate ] keep
- redraw ;
+ [ move-shape ] keep redraw ;
: resize-gadget ( w h gadget -- )
- [ resize-shape ] keep
- [ set-gadget-delegate ] keep
- redraw ;
-
-! A simple gadget that just draws its shape.
-TUPLE: stamp delegate ;
-
-C: stamp ( shape -- )
- swap <gadget> over set-stamp-delegate ;
-
-M: stamp draw ( stamp -- )
- dup [ gadget-delegate draw ] with-gadget ;
+ [ resize-shape ] keep redraw ;
TUPLE: hand click-pos clicked buttons delegate ;
C: hand ( world -- hand )
- 0 <gadget> <box>
+ 0 0 <point> <gadget> <box>
over set-hand-delegate
[ set-gadget-parent ] keep ;
swap size-string
] keep resize-gadget ;
-M: label draw ( label -- )
+M: label draw-shape ( label -- )
dup shape-x x get +
over shape-y y get +
rot label-text
>r font get lookup-font r>
color get 3unlist make-color
- white make-color
draw-string drop ;
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic hashtables kernel lists math namespaces ;
+
+! A pile is a box that lays out its contents vertically.
+TUPLE: pile delegate ;
+
+C: pile ( gadget -- pile )
+ [ >r <box> r> set-pile-delegate ] keep ;
+
+M: pile layout* ( pile -- )
+ dup gadget-children run-heights >r >r
+ dup gadget-children max-width r> pick resize-gadget
+ gadget-children r> zip [
+ uncons 0 swap rot move-gadget
+ ] each ;
+
+! A shelf is a box that lays out its contents horizontally.
+TUPLE: shelf delegate ;
+
+C: shelf ( gadget -- pile )
+ [ >r <box> r> set-shelf-delegate ] keep ;
+
+M: shelf layout* ( pile -- )
+ dup gadget-children run-widths >r >r
+ dup gadget-children max-height r> swap pick resize-gadget
+ gadget-children r> zip [
+ uncons 0 rot move-gadget
+ ] each ;
! dynamically-scoped variables.
! "Paint" is a namespace containing some or all of these values.
-SYMBOL: color ! a list of three integers, 0..255.
-SYMBOL: font ! a list of two elements, a font name and size.
-SYMBOL: filled ! is the interior of the shape filled?
+SYMBOL: color ! a list of three integers, 0..255.
+SYMBOL: font ! a list of two elements, a font name and size.
: shape>screen ( shape -- x1 y1 x2 y2 )
[ shape-x x get + ] keep
: rgb-color ( -- rgba ) color get 3unlist rgb ;
-GENERIC: draw ( obj -- )
+GENERIC: draw-shape ( obj -- )
-M: number draw ( point -- )
- >r surface get r> >rect rgb-color pixelColor ;
+M: rectangle draw-shape drop ;
-M: rectangle draw ( rect -- )
- >r surface get r> shape>screen rgb-color
- filled get [ boxColor ] [ rectangleColor ] ifte ;
+M: point draw-shape ( point -- )
+ >r surface get r> dup point-x swap point-y
+ rgb-color pixelColor ;
+
+TUPLE: hollow-rect delegate ;
+
+C: hollow-rect ( x y w h -- rect )
+ [ >r <rectangle> r> set-hollow-rect-delegate ] keep ;
+
+M: hollow-rect draw-shape ( rect -- )
+ >r surface get r> shape>screen rgb-color rectangleColor ;
+
+TUPLE: plain-rect delegate ;
+
+C: plain-rect ( x y w h -- rect )
+ [ >r <rectangle> r> set-plain-rect-delegate ] keep ;
+
+M: plain-rect draw-shape ( rect -- )
+ >r surface get r> shape>screen rgb-color boxColor ;
+
+: x1/x2/y1 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y1 )
+ >r >rect r> real swap ;
+
+: x1/x2/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y2 )
+ >r real r> >rect ;
+
+: x1/y1/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 y1 y2 )
+ >r >rect r> imaginary ;
+
+: x2/y1/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x2 y1 y2 )
+ >r imaginary r> >rect >r swap r> ;
+
+: (draw-bevel) ( #{ x1 y1 }# #{ x2 y2 }# -- )
+ surface get pick pick x1/x2/y1 240 240 240 rgb hlineColor
+ surface get pick pick x1/x2/y2 192 192 192 rgb hlineColor
+ surface get pick pick x1/y1/y2 240 240 240 rgb vlineColor
+ surface get pick pick x2/y1/y2 192 192 192 rgb vlineColor
+ 2drop ;
+
+TUPLE: bevel-rect delegate bevel ;
+
+C: bevel-rect ( bevel x y w h -- rect )
+ [ >r <rectangle> r> set-bevel-rect-delegate ] keep
+ [ set-bevel-rect-bevel ] keep ;
+
+: draw-bevel ( #{ x1 y1 }# #{ x2 y2 }# n -- )
+ [
+ pick over #{ 1 1 }# * +
+ pick pick #{ 1 1 }# * -
+ (draw-bevel)
+ ] repeat 2drop ;
+
+M: bevel-rect draw-shape ( rect -- )
+ shape>screen >r >r rect> r> r> rect> 3 draw-bevel ;
: default-paint ( -- paint )
{{
[[ x 0 ]]
[[ y 0 ]]
- [[ color [ 0 0 0 ] ]]
- [[ filled f ]]
+ [[ color [ 160 160 160 ] ]]
[[ font [[ "Monospaced" 12 ]] ]]
}} ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic hashtables kernel lists math namespaces ;
-
-! A pile is a box that lays out its contents vertically.
-TUPLE: pile delegate ;
-
-C: pile ( gadget -- pile )
- [ >r <box> r> set-pile-delegate ] keep ;
-
-M: pile layout* ( pile -- )
- dup gadget-children run-heights >r >r
- dup gadget-children max-width r> pick resize-gadget
- gadget-children r> zip [
- uncons 0 swap rot move-gadget
- ] each ;
GENERIC: shape-w
GENERIC: shape-h
-GENERIC: move-shape ( x y shape -- shape )
-GENERIC: resize-shape ( w h shape -- shape )
+GENERIC: move-shape ( x y shape -- )
+GENERIC: resize-shape ( w h shape -- )
: with-translation ( shape quot -- )
#! All drawing done inside the quotation is translated
r> call
] with-scope ; inline
-: translate ( point shape -- point )
- #! Translate a point relative to the shape.
- #! The rect>'ing of the given point won't be necessary as
- #! soon as all generics delegate.
- >r dup shape-x swap shape-y rect> r>
- dup shape-x swap shape-y rect> - ;
-
: max-width ( list -- n )
#! The width of the widest shape.
[ shape-w ] map [ > ] top ;
+: max-height ( list -- n )
+ #! The height of the tallest shape.
+ [ shape-h ] map [ > ] top ;
+
+: run-widths ( list -- w list )
+ #! Compute a list of running sums of widths of shapes.
+ [ 0 swap [ over , shape-w + ] each ] make-list ;
+
: run-heights ( list -- h list )
- #! Compute a list of accumilative sums of heights of shapes.
+ #! Compute a list of running sums of heights of shapes.
[ 0 swap [ over , shape-h + ] each ] make-list ;
-! A point, represented as a complex number, is the simplest type
-! of shape.
-M: number inside? = ;
+! A point is the simplest shape.
+TUPLE: point x y ;
+
+C: point ( x y -- point )
+ [ set-point-y ] keep [ set-point-x ] keep ;
+
+M: point inside? ( point point -- )
+ over shape-x over point-x = >r
+ swap shape-y swap point-y = r> and ;
-M: number shape-x real ;
-M: number shape-y imaginary ;
-M: number shape-w drop 0 ;
-M: number shape-h drop 0 ;
+M: point shape-x point-x ;
+M: point shape-y point-y ;
+M: point shape-w drop 0 ;
+M: point shape-h drop 0 ;
-M: number move-shape ( x y point -- point ) drop rect> ;
+M: point move-shape ( x y point -- )
+ tuck set-point-y set-point-x ;
+
+: translate ( point shape -- point )
+ #! Translate a point relative to the shape.
+ over shape-y over shape-y - >r
+ swap shape-x swap shape-x - r> <point> ;
! A rectangle maps trivially to the shape protocol.
TUPLE: rectangle x y w h ;
[ set-rectangle-y ] keep
[ set-rectangle-x ] keep ;
-M: number resize-shape ( w h point -- rect )
- >rect 2swap <rectangle> ;
+M: rectangle move-shape ( x y rect -- )
+ tuck set-rectangle-y set-rectangle-x ;
-M: rectangle move-shape ( x y rect -- rect )
- [ rectangle-w ] keep rectangle-h <rectangle> ;
-
-M: rectangle resize-shape ( w h rect -- rect )
- [ rectangle-x ] keep rectangle-y 2swap <rectangle> ;
+M: rectangle resize-shape ( w h rect -- )
+ tuck set-rectangle-h set-rectangle-w ;
: rectangle-x-extents ( rect -- x1 x2 )
dup rectangle-x x get + swap rectangle-w dupd + ;
! Delegates to a bounded shape, but absorbs all points.
WRAPPER: everywhere
M: everywhere inside? ( point world -- ? ) 2drop t ;
-
-M: everywhere move-shape ( x y everywhere -- )
- everywhere-delegate move-shape <everywhere> ;
-
-M: everywhere resize-shape ( w h everywhere -- )
- everywhere-delegate resize-shape <everywhere> ;
TUPLE: world running? hand delegate ;
: <world-box> ( -- box )
- 0 0 0 0 <rectangle> <everywhere> <stamp>
- dup blue 3list color set-paint-property
- dup t filled set-paint-property
+ 0 0 0 0 <plain-rect> <everywhere> <gadget>
+ dup [ 216 216 216 ] color set-paint-property
<box> ;
C: world ( -- world )
world get dup gadget-redraw? [
[
f over set-gadget-redraw?
- dup draw
- world-hand draw
+ dup draw-gadget
+ world-hand draw-gadget
] with-surface
] [
drop
: run-world ( -- )
world get world-running? [
<event> dup SDL_WaitEvent 1 = [
- handle-event draw-world layout-world run-world
+ handle-event layout-world draw-world run-world
] [
drop
] ifte
projects / factor.git / commitdiff