working on labels and fields
Slava Pestov
parent
8d565b6968
commit
36b97dd4ee
|
|
@ -8,7 +8,6 @@
|
|||
- special completion for USE:/IN:
|
||||
- vectors: ensure its ok with bignum indices
|
||||
- if gadgets are moved, added or deleted, update hand.
|
||||
- keyboard focus
|
||||
- keyboard gestures
|
||||
- text fields
|
||||
- code gc
|
||||
|
|
|
|||
|
|
@ -1,39 +1,8 @@
|
|||
! :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 ;
|
||||
|
|
|
|||
|
|
@ -1,48 +1,9 @@
|
|||
! :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
|
||||
|
|
@ -57,6 +18,9 @@ SYMBOL: surface
|
|||
: 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 )
|
||||
|
|
@ -180,7 +144,7 @@ global [
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -36,4 +36,4 @@ M: motion-event handle-event ( event -- )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,33 @@
|
|||
! 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 ;
|
||||
|
|
@ -85,8 +85,8 @@ C: hand ( world -- hand )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -12,16 +12,7 @@ C: label ( text -- )
|
|||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! 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.
|
||||
|
|
@ -125,3 +125,19 @@ M: plain-ellipse draw-shape ( ellipse -- )
|
|||
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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue