steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

scrolling bug fix and moving a few layout words

cvs
Slava Pestov 2005-09-03 20:28:42 +00:00
parent b0b5f4f79d
commit 5e51518044
11 changed files with 73 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
library/ui/borders.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-borders
USING: errors gadgets generic hashtables kernel lists math
namespaces sdl vectors ;
USING: errors gadgets gadgets-layouts generic hashtables kernel
math namespaces vectors ;
TUPLE: border size ;

4
library/ui/buttons.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-buttons
USING: gadgets gadgets-borders generic io kernel lists math
namespaces sdl sequences sequences styles threads ;
USING: gadgets gadgets-borders gadgets-layouts generic io kernel
lists math namespaces sdl sequences sequences styles threads ;
: button-down? ( n -- ? ) hand hand-buttons member? ;

5
library/ui/editors.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-editors
USING: gadgets gadgets-labels gadgets-scrolling generic kernel
math namespaces sdl sequences strings styles threads vectors ;
USING: gadgets gadgets-labels gadgets-layouts gadgets-scrolling
generic kernel math namespaces sdl sequences strings styles
threads vectors ;
! A blinking caret
TUPLE: caret ;

4
library/ui/events.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: alien generic kernel lists math namespaces prettyprint
sdl sequences vectors ;
USING: alien gadgets-layouts generic kernel lists math
namespaces sdl sequences vectors ;
GENERIC: handle-event ( event -- )

43
library/ui/gadgets.factor
View File

@ -43,31 +43,34 @@ C: gadget ( -- gadget )
{ 0 0 0 } dup <rect> over set-delegate
t over set-gadget-visible? ;
DEFER: add-invalid
GENERIC: user-input* ( ch gadget -- ? )
M: gadget user-input* 2drop t ;
: invalidate ( gadget -- )
t swap set-gadget-relayout? ;
: relayout ( gadget -- )
#! Relayout and redraw a gadget and its parent before the
#! next iteration of the event loop.
dup gadget-relayout? [
drop
] [
dup invalidate
dup gadget-root?
[ add-invalid ]
[ gadget-parent [ relayout ] when* ] ifte
] ifte ;
DEFER: add-invalid
: relayout-down ( gadget -- )
#! Relayout a gadget and its children.
dup add-invalid invalidate ;
GENERIC: children-on ( rect/point gadget -- list )
: set-gadget-dim ( dim gadget -- )
2dup rect-dim =
[ 2drop ] [ [ set-rect-dim ] keep relayout-down ] ifte ;
M: gadget children-on ( rect/point gadget -- list )
nip gadget-children ;
GENERIC: user-input* ( ch gadget -- ? )
: inside? ( bounds gadget -- ? )
dup gadget-visible?
[ >absolute intersects? ] [ 2drop f ] ifte ;
M: gadget user-input* 2drop t ;
: pick-up-list ( rect/point gadget -- gadget/f )
dupd children-on reverse-slice [ inside? ] find-with nip ;
: translate ( rect/point -- )
rect-loc origin [ v+ ] change ;
: pick-up ( rect/point gadget -- gadget )
2dup inside? [
[
dup translate 2dup pick-up-list dup
[ nip pick-up ] [ rot 2drop ] ifte
] with-scope
] [ 2drop f ] ifte ;

27
library/ui/hierarchy.factor
View File

@ -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 matrices namespaces
sequences vectors ;
USING: gadgets-layouts generic hashtables kernel lists math
namespaces sequences vectors ;
: remove-gadget ( gadget parent -- )
2dup gadget-children remove over set-gadget-children
@ -77,26 +77,3 @@ M: gadget focusable-child* drop t ;
: focusable-child ( gadget -- gadget )
dup focusable-child*
dup t = [ drop ] [ nip focusable-child ] ifte ;
GENERIC: children-on ( rect/point gadget -- list )
M: gadget children-on ( rect/point gadget -- list )
nip gadget-children ;
: inside? ( bounds gadget -- ? )
dup gadget-visible?
[ >absolute intersects? ] [ 2drop f ] ifte ;
: pick-up-list ( rect/point gadget -- gadget/f )
dupd children-on reverse-slice [ inside? ] find-with nip ;
: translate ( rect/point -- )
rect-loc origin [ v+ ] change ;
: pick-up ( rect/point gadget -- gadget )
2dup inside? [
[
dup translate 2dup pick-up-list dup
[ nip pick-up ] [ rot 2drop ] ifte
] with-scope
] [ 2drop f ] ifte ;

2
library/ui/labels.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-labels
USING: gadgets generic hashtables io kernel lists math
USING: gadgets gadgets-layouts generic hashtables io kernel math
namespaces sdl sequences styles vectors ;
! A label gadget draws a string.

19
library/ui/layouts.factor
View File

@ -4,6 +4,25 @@ IN: gadgets-layouts
USING: errors gadgets generic hashtables kernel lists math
matrices namespaces sdl sequences ;
: relayout ( gadget -- )
#! Relayout and redraw a gadget and its parent before the
#! next iteration of the event loop.
dup gadget-relayout? [
drop
] [
dup invalidate
dup gadget-root?
[ add-invalid ]
[ gadget-parent [ relayout ] when* ] ifte
] ifte ;
: set-gadget-dim ( dim gadget -- )
2dup rect-dim = [
2drop
] [
[ set-rect-dim ] keep dup add-invalid invalidate
] ifte ;
GENERIC: pref-dim ( gadget -- dim )
M: gadget pref-dim rect-dim ;

2
library/ui/load.factor
View File

@ -1,12 +1,12 @@
USING: kernel parser sequences io ;
[
"/library/ui/gadgets.factor"
"/library/ui/layouts.factor"
"/library/ui/hierarchy.factor"
"/library/ui/paint.factor"
"/library/ui/fonts.factor"
"/library/ui/text.factor"
"/library/ui/gestures.factor"
"/library/ui/layouts.factor"
"/library/ui/borders.factor"
"/library/ui/frames.factor"
"/library/ui/world.factor"

29
library/ui/scrolling.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-scrolling
USING: gadgets gadgets-layouts generic kernel lists math
namespaces sequences threads vectors styles ;
USING: gadgets gadgets-books gadgets-layouts generic kernel
lists math namespaces sequences styles threads vectors ;
! A viewport can be scrolled.
TUPLE: viewport ;
TUPLE: viewport bottom? ;
! A scroller combines a viewport with two x and y sliders.
TUPLE: scroller viewport x y bottom? ;
TUPLE: scroller viewport x y ;
: scroller-origin ( scroller -- { x y 0 } )
dup scroller-x slider-value
@ -17,6 +17,8 @@ TUPLE: scroller viewport x y bottom? ;
: find-scroller [ scroller? ] find-parent ;
: find-viewport [ viewport? ] find-parent ;
: viewport-dim gadget-child pref-dim ;
C: viewport ( content -- viewport )
@ -44,8 +46,12 @@ M: viewport pref-dim gadget-child pref-dim ;
: update-scroller ( scroller -- ) dup scroller-origin scroll ;
: update-viewport ( viewport scroller -- )
scroller-origin vneg
swap gadget-child dup prefer set-rect-loc ;
over viewport-bottom? [
f pick set-viewport-bottom?
over viewport-dim
] [
dup scroller-origin
] ifte vneg nip swap gadget-child dup prefer set-rect-loc ;
M: viewport layout* ( viewport -- )
dup find-scroller dup update-scroller update-viewport ;
@ -60,8 +66,8 @@ M: viewport focusable-child* ( viewport -- gadget )
: add-y-slider 2dup set-scroller-y add-right ;
: scroll>bottom ( gadget -- )
find-scroller
[ t over set-scroller-bottom? relayout ] when* ;
find-viewport
[ t over set-viewport-bottom? relayout ] when* ;
: scroll-up-line scroller-y -1 swap slide-by-line ;
@ -82,10 +88,3 @@ C: scroller ( gadget -- scroller )
M: scroller focusable-child* ( scroller -- viewport )
scroller-viewport ;
M: scroller layout* ( scroller -- )
dup scroller-bottom? [
f over set-scroller-bottom?
dup dup scroller-viewport viewport-dim
{ 0 1 0 } v* scroll
] when delegate layout* ;

7
library/ui/ui.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: gadgets-listener generic help io kernel listener lists
math namespaces prettyprint sdl sequences shells styles threads
words ;
USING: gadgets-layouts gadgets-listener generic help io kernel
listener lists math namespaces prettyprint sdl sequences shells
styles threads words ;
: world-theme
{{
@ -19,6 +19,7 @@ words ;
}} ;
: init-world
ttf-init
global [
<world> world set
{ 600 800 0 } world get set-gadget-dim