label gadget

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index d88965f0c2eb3df72fb87f7a3f73db7a3b21ac30..06e6201b406736c9791ffc20e7c7dfedb86779af 100644 (file)
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -159,6 +159,8 @@ cpu "x86" = [
         "/library/ui/gestures.factor"\r
         "/library/ui/hand.factor"\r
         "/library/ui/world.factor"\r
+        "/library/ui/label.factor"\r
+        "/library/ui/events.factor"\r
     ] [\r
         dup print\r
         run-resource\r

diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor
index efba5137a9812cdf6a769b36029543b36d3c1de7..5113292f7ec8c4f9cffb1120b21db81b3fca799d 100644 (file)
--- a/library/sdl/sdl-utils.factor
+++ b/library/sdl/sdl-utils.factor
@@ -42,6 +42,7 @@ USE: sdl-video
 USE: streams
 USE: strings
 USE: sdl-ttf
+USE: hashtables
 
 SYMBOL: surface
 SYMBOL: width
@@ -119,12 +120,23 @@ SYMBOL: fonts
 : <font> ( name ptsize -- font )
     >r resource-path swap cat2 r> TTF_OpenFont ;
 
-: font ( name ptsize -- font )
+SYMBOL: logical-fonts
+
+: logical-font ( name -- name )
+    dup logical-fonts get hash dup [ nip ] [ drop ] ifte ;
+
+global [
+    {{
+        [[ "Monospaced" "/fonts/VeraMono.ttf" ]]
+    }} logical-fonts set
+] bind
+
+: lookup-font ( [[ name ptsize ]] -- font )
     fonts get [
-        2dup cons get [
-            2nip
+        unswons logical-font swons dup get [
+            nip
         ] [
-            2dup cons >r <font> dup r> set
+            [ uncons <font> dup ] keep set
         ] ifte*
     ] bind ;
 
@@ -139,9 +151,13 @@ SYMBOL: fonts
     dup surface-w swap surface-h make-rect ;
 
 : draw-surface ( x y surface -- )
+    surface get SDL_UnlockSurface
     [
         [ surface-rect ] keep swap surface get 0 0
-    ] keep surface-rect swap rot SDL_UpperBlit drop ;
+    ] keep surface-rect swap rot SDL_UpperBlit drop
+    surface get dup must-lock-surface? [
+        SDL_LockSurface
+    ] when drop ;
 
 : draw-string ( x y font text fg bg -- width )
     pick str-length 0 = [

diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor
index 322eba4137f3bcb3ec36019800f69851e6ea9cc0..8e36a5e28f1ac22e3d0090917f0f4b0e04c804ad 100644 (file)
--- a/library/test/gadgets.factor
+++ b/library/test/gadgets.factor
@@ -49,13 +49,3 @@ USING: gadgets kernel lists math namespaces test ;
         pick-up
     ] bind
 ] unit-test
-    
-[ 30 ] [
-    default-paint [
-        35 10 rect>
-        [ 10 30 50 70 ] [ funny-rect ] map
-        0 0 200 200 <rect> <gadget> <ghost> <box>
-        [ set-box-contents ] keep
-        pick-up shape-x
-    ] bind
-] unit-test

diff --git a/library/ui/console.factor b/library/ui/console.factor
index 526507a0c22cc07ff817000c6622ed89981277e7..c5cfaa506c02407bf372db7e5997639d24d58f4e 100644 (file)
--- a/library/ui/console.factor
+++ b/library/ui/console.factor
@@ -345,7 +345,7 @@ M: alien handle-event ( event -- ? )
     ] ifte ;
 
 : set-console-font ( font ptsize )
-    font dup console-font set
+    cons lookup-font dup console-font set
     TTF_FontHeight line-height set ;
 
 : init-console ( -- )

diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor
index 992136316d47b9a57e86ac591b6cc3f8d2c8f073..06c0e661748a4538816bf04f8d0a969dde5aea5c 100644 (file)
--- a/library/ui/gadgets.factor
+++ b/library/ui/gadgets.factor
@@ -39,8 +39,7 @@ C: gadget ( shape -- gadget )
     #! paint, just call the quotation.
     >r gadget-paint r> bind ;
 
-M: gadget draw ( gadget -- )
-    dup [ gadget-delegate draw ] with-gadget ;
+M: gadget draw ( gadget -- ) drop ;
 
 M: gadget pick-up* inside? ;
 
@@ -56,8 +55,11 @@ DEFER: redraw ( gadget -- )
     [ set-gadget-delegate ] keep
     redraw ;
 
-! An invisible gadget.
-WRAPPER: ghost
-M: ghost draw drop ;
-M: ghost pick-up* 2drop f ;
-M: ghost draw drop ;
+! 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 ;

diff --git a/library/ui/hand.factor b/library/ui/hand.factor
index e84289a177719e178176e558a4c105b783e920ca..c2c6663bb888fbd3d432ab247fa72822e3afbd2a 100644 (file)
--- a/library/ui/hand.factor
+++ b/library/ui/hand.factor
@@ -13,7 +13,7 @@ SYMBOL: world
 TUPLE: hand click-pos clicked buttons delegate ;
 
 C: hand ( world -- hand )
-    0 <gadget> <ghost> <box>
+    0 <gadget> <box>
     over set-hand-delegate
     [ set-gadget-parent ] keep ;
 

diff --git a/library/ui/label.factor b/library/ui/label.factor
new file mode 100644 (file)
index 0000000..359ba0f
--- /dev/null
+++ b/library/ui/label.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists math namespaces sdl ;
+
+! A label draws a text label, centered on the gadget's bounding
+! box.
+TUPLE: label text delegate ;
+
+: size-label ( label -- )
+    [
+        dup label-text swap gadget-paint
+        [ font get lookup-font ] bind
+        swap size-string
+    ] keep resize-gadget ;
+
+C: label ( text -- )
+    0 0 0 0 <rectangle> <gadget> over set-label-delegate
+    [ set-label-text ] keep
+    [ size-label ] keep ;
+
+M: label draw ( 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 ;

diff --git a/library/ui/paint.factor b/library/ui/paint.factor
index a0b9ec628ba2aaba1fc416e48771335bc6070ed2..3885e34e2c9e8b849bdddb4031f5610d00090579 100644 (file)
--- a/library/ui/paint.factor
+++ b/library/ui/paint.factor
@@ -34,5 +34,5 @@ M: rectangle draw ( rect -- )
         [[ y 0 ]]
         [[ color [ 0 0 0 ] ]]
         [[ filled f ]]
-        [[ font [ "Monospaced" 12 ] ]]
+        [[ font [[ "Monospaced" 12 ]] ]]
     }} ;

diff --git a/library/ui/world.factor b/library/ui/world.factor
index a8e428a1a2daf44f04516a1d4fe514636ce5b341..91c60135da02fa6b20276b03811b336151f112a0 100644 (file)
--- a/library/ui/world.factor
+++ b/library/ui/world.factor
@@ -10,7 +10,7 @@ sdl-video ;
 TUPLE: world running? hand delegate redraw? ;
 
 : <world-box> ( -- box )
-    0 0 0 0 <rectangle> <everywhere> <gadget>
+    0 0 0 0 <rectangle> <everywhere> <stamp>
     dup blue 3list color set-paint-property
     dup t filled set-paint-property
     <box> ;