started clipping

examples/gadget-test.factor

@@ -76,8 +76,8 @@ USE: words
 !    "Another field."  <field> "pile" get add-gadget
     scroller "pile" get add-gadget
 
-    "pile" get bevel-border dup "dialog" set dup  
+    "pile" get bevel-border dup "dialog" set ! dup  
- moving-actions
+! moving-actions
   world get add-gadget ;
 
 : gadget-demo ( -- )

library/sdl/sdl-video.factor

@@ -1,35 +1,7 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
 ! Copyright (C) 2004, 2005 Slava Pestov.
-! 
+! See http://factor.sf.net/license.txt for BSD license.
-! 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.
-
 IN: sdl-video
-USE: alien
+USING: alien kernel math ;
-USE: compiler
-USE: kernel
-USE: 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 ;
 

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 )

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 -- ? )

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
 

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

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 ;

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
+USING: generic hashtables kernel lists math namespaces sdl
-sdl sdl-gfx sdl-ttf strings ;
+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
+            set-clip
-        ] with-translation
+            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

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.
     [

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> ( -- 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 slider-drag over shape-h / over slider-viewport
-        dup screen-pos my-hand screen-pos - shape-y
+    scroll-viewport relayout ;
-        over shape-h / over slider-viewport scroll-viewport
-        relayout
-    ] [
-        drop
-    ] ifte ;
 
 : slider-actions ( slider -- )
-    dup [ slider-motion ] [ motion ] set-action
+    dup [ slider-click ] [ button-down 1 ] set-action
-    dup [ t swap set-slider-scrolling? ] [ button-down 1 ] set-action
+    [ slider-motion ] [ drag ] set-action ;
-    [ f swap set-slider-scrolling? ] [ button-up 1 ] 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 )

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
-        [ <event> run-world ] with-screen
+        [
+            title dup SDL_WM_SetCaption
+            <event> run-world
+        ] with-screen
     ] with-scope ;
 
 global [