gadget-test

diff --git a/examples/gadget-test.factor b/examples/gadget-test.factor
new file mode 100644 (file)
index 0000000..e5ec68d
--- /dev/null
+++ b/examples/gadget-test.factor
@@ -0,0 +1,83 @@
+! TrueType font rendering demo.
+!
+! To run this code, bootstrap Factor like so:
+!
+! ./f boot.image.le32
+!     -libraries:sdl:name=libSDL.so
+!     -libraries:sdl-gfx:name=libSDL_gfx.so
+!     -libraries:sdl-ttf:name=libSDL_ttf.so
+!
+! (But all on one line)
+!
+! Then, start Factor as usual (./f factor.image) and enter this
+! at the listener:
+!
+! "examples/text-demo.factor" run-file
+
+IN: text-demo
+USE: streams
+USE: sdl
+USE: sdl-event
+USE: sdl-gfx
+USE: sdl-video
+USE: sdl-ttf
+USE: namespaces
+USE: math
+USE: kernel
+USE: test
+USE: compiler
+USE: strings
+USE: alien
+USE: prettyprint
+USE: lists
+USE: gadgets
+USE: generic
+USE: stdio
+USE: prettyprint
+USE: words
+
+: moving-actions
+    {{
+        [[ [ button-down 1 ] [ 0 0 pick move-gadget my-hand add-gadget ] ]]
+        [[ [ button-up 1 ] [ my-hand shape-x my-hand shape-y pick move-gadget world get add-gadget ] ]]
+    }} swap set-gadget-gestures ;
+
+: <funny-rect>
+    <plain-rect> <gadget> dup moving-actions ;
+
+: <funny-ellipse>
+    <plain-ellipse> <gadget> dup moving-actions ;
+
+: <funny-line>
+    <line> <gadget> dup moving-actions ;
+
+: check-box ( label -- checkbox )
+    0 0 0 0 <rectangle> <shelf>
+    [ >r <label> r> add-gadget ] keep
+    [ >r f bevel-border r> add-gadget ] keep ;
+
+: make-shapes ( -- )
+    f world get set-gadget-children
+    
+    100 20 0 0 <rectangle> <pile> "pile" set
+    0 0 0 0 <rectangle> <shelf> "shelf" set
+    "Close" [ "dialog" get world get remove-gadget ] <button> "shelf" get add-gadget
+    "New Rectangle" [ drop 100 100 100 100 <funny-rect> dup [ 255 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
+    "New Ellipse" [ drop 100 100 200 100 <funny-ellipse> dup [ 0 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
+    "New Line" [ drop 100 100 200 100 <funny-line> dup [ 255 0 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
+    "A check box" [ drop ] <check-box> "shelf" get add-gadget
+    "shelf" get "pile" get add-gadget
+    "Welcome to Factor " version cat2 <label> "pile" get add-gadget
+
+    "pile" get bevel-border dup "dialog" set dup  
+ {{
+         [[ [ button-down 1 ] [ dup unparent 0 0 pick move-gadget my-hand add-gadget ] ]]
+         [[ [ button-up 1 ] [ my-hand shape-x my-hand shape-y pick move-gadget world get add-gadget ] ]]
+     }} swap set-gadget-gestures
+  world get add-gadget ;
+
+: gadget-demo ( -- )
+    make-shapes
+    start-world ;
+
+gadget-demo