- special completion for USE:/IN:\r
- vectors: ensure its ok with bignum indices\r
- if gadgets are moved, added or deleted, update hand.\r
-- keyboard focus\r
- keyboard gestures\r
- text fields\r
- code gc\r
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms ; with or without
-! modification ; are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice ;
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice ;
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES ;
-! INCLUDING ; BUT NOT LIMITED TO ; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT ; INDIRECT ; INCIDENTAL ;
-! SPECIAL ; EXEMPLARY ; OR CONSEQUENTIAL DAMAGES (INCLUDING ; BUT NOT LIMITED TO ;
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE ; DATA ; OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY ;
-! WHETHER IN CONTRACT ; STRICT LIABILITY ; OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE ; EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
IN: sdl-keyboard
-USE: alien
-USE: lists
-USE: sdl-keysym
-USE: namespaces
-USE: sdl-event
-USE: kernel
-USE: math
-USE: hashtables
+USING: alien lists sdl-keysym namespaces sdl-event kernel
+math hashtables ;
: SDL_EnableUNICODE ( enable -- )
"int" "sdl" "SDL_EnableUNICODE" [ "int" ] alien-invoke ;
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
! Copyright (C) 2004, 2005 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! See http://factor.sf.net/license.txt for BSD license.
IN: sdl
-USE: alien
-USE: math
-USE: namespaces
-USE: compiler
-USE: words
-USE: parser
-USE: kernel
-USE: errors
-USE: lists
-USE: prettyprint
-USE: sdl-event
-USE: sdl-gfx
-USE: sdl-video
-USE: streams
-USE: strings
-USE: sdl-ttf
-USE: hashtables
+USING: alien math namespaces compiler words parser kernel errors
+lists prettyprint sdl-event sdl-gfx sdl-keyboard sdl-video
+streams strings sdl-ttf hashtables ;
SYMBOL: surface
SYMBOL: width
: with-screen ( width height bpp flags quot -- )
#! Set up SDL graphics and call the quotation.
SDL_INIT_EVERYTHING SDL_Init drop TTF_Init
+ 1 SDL_EnableUNICODE drop
+ SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL
+ SDL_EnableKeyRepeat drop
[ >r init-screen r> call SDL_Quit ] with-scope ; inline
: rgb ( [ r g b ] -- n )
] ifte ;
: size-string ( font text -- w h )
- dup str-length 0 = [
+ >r lookup-font r> dup str-length 0 = [
drop TTF_FontHeight 0 swap
] [
<int-box> <int-box> [ TTF_SizeUNICODE drop ] 2keep
motion-event-pos my-hand move-hand ;
M: key-down-event handle-event ( event -- )
- keyboard-event>binding my-hand hand-gadget handle-gesture ;
+ keyboard-event>binding my-hand hand-focus handle-gesture ;
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists math namespaces sdl line-editor ;
+
+TUPLE: field active? delegate ;
+
+: field-border ( gadget -- border )
+ bevel-border dup f bevel-up? set-paint-property ;
+
+C: field ( delegate -- field )
+ [ >r field-border r> set-field-delegate ] keep
+ {{
+ [[ [ gain-focus ] [ dup blue foreground set-paint-property redraw ] ]]
+ [[ [ lose-focus ] [ dup black foreground set-paint-property redraw ] ]]
+ [[ [ button-down 1 ] [ my-hand request-focus ] ]]
+ [[ [ "RETURN" ] [ drop "foo!" USE: stdio print ] ]]
+ }} over set-gadget-gestures ;
+
+TUPLE: editor line delegate ;
+
+C: editor ( -- )
+ 0 0 0 0 <rectangle> <gadget> over set-editor-delegate
+ [ <line-editor> set-editor-line ] keep ;
+
+: editor-text ( editor -- text )
+ editor-line [ line-text get ] bind ;
+
+M: editor layout* ( label -- )
+ [ editor-text dup shape-w swap shape-h ] keep resize-gadget ;
+
+M: editor draw-shape ( label -- )
+ dup [ editor-text draw-shape ] with-translation ;
dup fire-motion
r> swap fire-enter ;
-: request-focus ( gadget -- )
- my-hand hand-focus
+: request-focus ( gadget hand -- )
+ dup >r hand-focus
2dup lose-focus
- swap dup my-hand set-hand-focus
+ swap dup r> set-hand-focus
gain-focus ;
[ set-label-text ] keep ;
M: label layout* ( label -- )
- [
- dup label-text swap gadget-paint
- [ font get lookup-font ] bind
- swap size-string
- ] keep resize-gadget ;
+ [ label-text dup shape-w swap shape-h ] keep resize-gadget ;
M: label draw-shape ( label -- )
- dup shape-x x get +
- over shape-y y get +
- rot label-text
- >r font get lookup-font r>
- foreground get 3unlist make-color
- draw-string drop ;
+ dup [ label-text draw-shape ] with-translation ;
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic hashtables kernel lists math namespaces
-sdl sdl-gfx ;
+sdl sdl-gfx sdl-ttf strings ;
! The painting protocol. Painting is controlled by various
! dynamically-scoped variables.
gadget-children [ draw-gadget ] each
] with-translation
] bind ;
+
+! Strings are shapes too. This is somewhat of a hack and strings
+! do not have x/y co-ordinates.
+M: string shape-x drop 0 ;
+M: string shape-y drop 0 ;
+M: string shape-w
+ font get swap size-string ( h -) drop ;
+
+M: string shape-h ( text -- h )
+ #! This is just the height of the current font.
+ drop font get lookup-font TTF_FontHeight ;
+
+M: string draw-shape ( text -- )
+ >r x get y get font get lookup-font r>
+ foreground get 3unlist make-color
+ draw-string drop ;