From 033ece6ca5496232be0aaad372e1eea20312acff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 26 Feb 2005 07:11:25 +0000 Subject: [PATCH] started clipping --- examples/gadget-test.factor | 4 ++-- library/sdl/sdl-video.factor | 35 +++++---------------------------- library/ui/fields.factor | 4 ++-- library/ui/gadgets.factor | 2 +- library/ui/gestures.factor | 1 + library/ui/hand.factor | 10 +++++++++- library/ui/labels.factor | 2 +- library/ui/paint.factor | 19 ++++++++++++------ library/ui/shapes.factor | 15 ++++++++++++-- library/ui/viewports.factor | 38 ++++++++++++++++++++++++------------ library/ui/world.factor | 10 ++++++++-- 11 files changed, 80 insertions(+), 60 deletions(-) diff --git a/examples/gadget-test.factor b/examples/gadget-test.factor index c7f6a1c89d..f0d6f7e208 100644 --- a/examples/gadget-test.factor +++ b/examples/gadget-test.factor @@ -76,8 +76,8 @@ USE: words ! "Another field." "pile" get add-gadget scroller "pile" get add-gadget - "pile" get bevel-border dup "dialog" set dup - moving-actions + "pile" get bevel-border dup "dialog" set ! dup +! moving-actions world get add-gadget ; : gadget-demo ( -- ) diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor index a7c1722484..fcec0f5414 100644 --- a/library/sdl/sdl-video.factor +++ b/library/sdl/sdl-video.factor @@ -1,35 +1,7 @@ -! :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-video -USE: alien -USE: compiler -USE: kernel -USE: math +USING: alien kernel math ; ! These are the currently supported flags for the SDL_surface ! Available for SDL_CreateRGBSurface() or SDL_SetVideoMode() @@ -165,6 +137,9 @@ END-STRUCT : SDL_UnlockSurface ( surface -- ) "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-invoke ; +: SDL_SetClipRect ( surface rect -- ? ) + "bool" "sdl" "SDL_SetClipRect" [ "surface*" "rect*" ] alien-invoke ; + : SDL_FreeSurface ( surface -- ) "void" "sdl" "SDL_FreeSurface" [ "surface*" ] alien-invoke ; diff --git a/library/ui/fields.factor b/library/ui/fields.factor index 70e18baaca..72cf4822b7 100644 --- a/library/ui/fields.factor +++ b/library/ui/fields.factor @@ -65,7 +65,7 @@ M: editor layout* ( field -- ) dup editor-caret swap caret-pos rot move-gadget ; M: editor draw-shape ( label -- ) - dup [ editor-text draw-shape ] with-translation ; + dup [ editor-text draw-shape ] with-trans ; TUPLE: field active? editor delegate ; @@ -78,7 +78,7 @@ TUPLE: field active? editor delegate ; : click-editor ( editor -- ) my-hand - 2dup relative-pos shape-x pick set-caret-x + 2dup relative shape-x pick set-caret-x request-focus ; : field-border ( gadget -- border ) diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 09b73c3762..b3e924d8bd 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -91,7 +91,7 @@ C: gadget ( shape -- gadget ) #! The position of the gadget on the screen. 0 swap [ shape-pos + t ] each-parent drop ; -: relative-pos ( g1 g2 -- g2-p1 ) +: relative ( g1 g2 -- g2-p1 ) shape-pos swap screen-pos - ; : child? ( parent child -- ? ) diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index a126c17a3f..4b10ea091f 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -31,6 +31,7 @@ M: gadget user-input* 2drop t ; ! Mouse gestures are lists where the first element is one of: SYMBOL: motion +SYMBOL: drag SYMBOL: button-up SYMBOL: button-down diff --git a/library/ui/hand.factor b/library/ui/hand.factor index d25b04500c..28ba565539 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -76,7 +76,15 @@ C: hand ( world -- hand ) dup dup hand-world pick-up swap set-hand-gadget ; : fire-motion ( hand -- ) - [ motion ] swap hand-gadget handle-gesture drop ; + #! Fire a motion gesture to the gadget underneath the hand, + #! and if a mouse button is down, fire a drag gesture to the + #! gadget that was clicked. + [ motion ] over hand-gadget handle-gesture drop + dup hand-buttons [ + [ drag ] swap hand-clicked handle-gesture drop + ] [ + drop + ] ifte ; : move-hand ( x y hand -- ) dup shape-pos >r diff --git a/library/ui/labels.factor b/library/ui/labels.factor index 9a19af009f..d86311e92b 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -22,4 +22,4 @@ M: label layout* ( label -- ) M: label draw-shape ( label -- ) dup label-x over label-y rect> over shape-pos + - [ label-text draw-shape ] with-translation ; + [ label-text draw-shape ] with-trans ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index f91433989a..fb386ed308 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic hashtables kernel lists math namespaces -sdl sdl-gfx sdl-ttf strings ; +USING: generic hashtables kernel lists math namespaces sdl +sdl-gfx sdl-ttf sdl-video strings ; ! The painting protocol. Painting is controlled by various ! dynamically-scoped variables. @@ -113,17 +113,24 @@ C: plain-ellipse ( x y w h -- ellipse ) M: plain-ellipse draw-shape ( ellipse -- ) >r surface get r> ellipse>screen background get rgb - filledEllipseColor ; + filledEllipseColor ; + +: set-clip ( -- ) + surface get x get y get width get height get make-rect + SDL_SetClipRect drop ; : 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. dup gadget-paint [ - dup draw-shape dup [ - gadget-children [ draw-gadget ] each - ] with-translation + set-clip + dup draw-shape + dup [ + gadget-children [ draw-gadget ] each + ] with-trans + ] with-clip ] bind ; ! Strings are shapes too. This is somewhat of a hack and strings diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 2e7bb3fb45..e142cf5d7f 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel lists math namespaces ; +USING: generic kernel lists math namespaces sdl ; ! Shape protocol. Shapes are immutable; moving or resizing a ! shape makes a new shape. @@ -23,7 +23,18 @@ GENERIC: shape-h GENERIC: move-shape ( x y shape -- ) GENERIC: resize-shape ( w h shape -- ) -: with-translation ( shape quot -- ) +: clip-w ( gadget -- ) + width [ nip ( over shape-x - swap shape-w min 0 max ) ] change ; + +: clip-h ( gadget -- ) + height [ nip ( over shape-y - swap shape-h min 0 max ) ] change ; + +: with-clip ( shape quot -- ) + #! All drawing done inside the quotation is clipped to the + #! shape's bounds. + [ >r dup clip-w clip-h r> call ] with-scope ; inline + +: with-trans ( shape quot -- ) #! All drawing done inside the quotation is translated #! relative to the shape's origin. [ diff --git a/library/ui/viewports.factor b/library/ui/viewports.factor index d7ddcc737c..99601ca651 100644 --- a/library/ui/viewports.factor +++ b/library/ui/viewports.factor @@ -14,22 +14,30 @@ C: viewport ( content -- viewport ) M: viewport layout* ( viewport -- ) dup gadget-children [ - >r dup viewport-scroll-x swap viewport-scroll-y r> + >r dup viewport-x swap viewport-y r> move-gadget ] each-with ; : viewport-h ( viewport -- h ) gadget-children max-height ; : viewport-w ( viewport -- w ) gadget-children max-width ; +: adjust-scroll ( y viewport -- y ) + #! Make sure we don't scroll above the first line, or beyond + #! the end of the document. + dup shape-h swap viewport-h - max 0 min ; + : scroll-viewport ( y viewport -- ) #! y is a number between 0 and 1. [ viewport-h * >fixnum ] keep + [ adjust-scroll ] keep [ set-viewport-y ] keep relayout ; ! A slider scrolls a viewport. -TUPLE: slider viewport thumb scrolling? delegate ; +! The offset slot is the y co-ordinate of the mouse relative to +! the thumb when it was clicked. +TUPLE: slider viewport thumb offset delegate ; : ( -- thumb ) f bevel-border @@ -40,19 +48,23 @@ TUPLE: slider viewport thumb scrolling? delegate ; : slider-size 20 ; +: hand-y ( gadget -- y ) + #! Vertical offset of hand from gadget. + my-hand swap relative shape-y ; + +: slider-click ( slider -- ) + [ slider-thumb hand-y ] keep set-slider-offset ; + +: slider-drag ( slider -- y ) + [ hand-y ] keep slider-offset - ; + : slider-motion ( slider -- ) - dup slider-scrolling? [ - dup screen-pos my-hand screen-pos - shape-y - over shape-h / over slider-viewport scroll-viewport - relayout - ] [ - drop - ] ifte ; + dup slider-drag over shape-h / over slider-viewport + scroll-viewport relayout ; : slider-actions ( slider -- ) - dup [ slider-motion ] [ motion ] set-action - dup [ t swap set-slider-scrolling? ] [ button-down 1 ] set-action - [ f swap set-slider-scrolling? ] [ button-up 1 ] set-action ; + dup [ slider-click ] [ button-down 1 ] set-action + [ slider-motion ] [ drag ] set-action ; C: slider ( viewport -- slider ) [ set-slider-viewport ] keep @@ -65,7 +77,7 @@ C: slider ( viewport -- slider ) [ slider-actions ] keep ; : visible-portion ( viewport -- float ) - #! Visible portion, > 0, <= 1. + #! Visible portion, between 0 and 1. dup shape-h swap viewport-h 1 max / 1 min ; : >thumb ( slider y -- y ) diff --git a/library/ui/world.factor b/library/ui/world.factor index 946d8f8411..2674b812da 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: alien generic kernel lists math namespaces sdl sdl-event -sdl-video threads ; +sdl-video strings threads ; ! The world gadget is the top level gadget that all (visible) ! gadgets are contained in. The current world is stored in the @@ -63,6 +63,9 @@ DEFER: handle-event drop ] ifte ; +: title ( -- str ) + "Factor " version cat2 ; + : start-world ( -- ) #! Start the Factor graphics subsystem with the given screen #! dimensions. @@ -71,7 +74,10 @@ DEFER: handle-event [ 0 x set 0 y set - [ run-world ] with-screen + [ + title dup SDL_WM_SetCaption + run-world + ] with-screen ] with-scope ; global [