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

some UI refactoring

cvs
Slava Pestov 2005-10-08 00:26:21 +00:00
parent 26d0e7ede5
commit 47f511d8a6
19 changed files with 190 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
TODO.FACTOR.txt
View File

@ -24,11 +24,12 @@
- get outliner working with lots of lines of output
- listener continuations
- test copy-into of a sequence into itself
- vertical alignment of arrows -vs- outliner gadget
- slice: if sequence or seq start is changed, abstraction violation
- apropos: use new smarter completion?
+ ui:
- pane should not scroll all the way to the right if long lines are present
- multi-part gradients
- tabular output
- debugger should use outlining
@ -84,6 +85,7 @@
- the invalid recursion form case needs to be fixed, for inlines too
- recursion is iffy; if the stack at the recursive call doesn't match
up, throw an error
- compile continuations
+ sequences:

1
library/collections/strings.factor
View File

@ -18,6 +18,7 @@ PREDICATE: integer letter CHAR: a CHAR: z between? ;
PREDICATE: integer LETTER CHAR: A CHAR: Z between? ;
PREDICATE: integer digit CHAR: 0 CHAR: 9 between? ;
PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
PREDICATE: integer control "\0\e\r\n\t\u0008\u007f" member? ;
: quotable? ( ch -- ? )
#! In a string literal, can this character be used without

89
library/sdl/sdl-utils.factor
View File

@ -1,27 +1,68 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sdl
USING: errors kernel lists math namespaces sequences ;
USING: alien arrays errors hashtables io kernel lists math
namespaces sequences styles ;
SYMBOL: surface
SYMBOL: width
SYMBOL: height
SYMBOL: bpp
: init-screen ( width height bpp flags -- )
>r 3dup bpp set height set width set r>
SDL_SetVideoMode surface set ;
: sdl-error ( 0/-1 -- )
0 = [ SDL_GetError throw ] unless ;
: with-screen ( width height bpp flags quot -- )
#! Set up SDL graphics and call the quotation.
SDL_INIT_EVERYTHING SDL_Init sdl-error
: ttf-name ( font style -- name )
cons {{
[[ [[ "Monospaced" plain ]] "VeraMono" ]]
[[ [[ "Monospaced" bold ]] "VeraMoBd" ]]
[[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]]
[[ [[ "Monospaced" italic ]] "VeraMoIt" ]]
[[ [[ "Sans Serif" plain ]] "Vera" ]]
[[ [[ "Sans Serif" bold ]] "VeraBd" ]]
[[ [[ "Sans Serif" bold-italic ]] "VeraBI" ]]
[[ [[ "Sans Serif" italic ]] "VeraIt" ]]
[[ [[ "Serif" plain ]] "VeraSe" ]]
[[ [[ "Serif" bold ]] "VeraSeBd" ]]
[[ [[ "Serif" bold-italic ]] "VeraBI" ]]
[[ [[ "Serif" italic ]] "VeraIt" ]]
}} hash ;
: ttf-path ( name -- string )
[ "/fonts/" % % ".ttf" % ] "" make resource-path ;
: open-font ( { font style ptsize } -- alien )
first3 >r ttf-name ttf-path r> TTF_OpenFont
dup alien-address 0 = [ SDL_GetError throw ] when ;
SYMBOL: open-fonts
: lookup-font ( font style ptsize -- font )
3array open-fonts get [ open-font ] cache ;
: init-ttf ( -- )
TTF_Init sdl-error
global [
open-fonts [ [ cdr expired? not ] hash-subset ] change
] bind ;
: init-keyboard ( -- )
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
SDL_EnableKeyRepeat drop ;
: init-surface ( width height bpp flags -- )
>r 3dup bpp set height set width set r>
SDL_SetVideoMode surface set ;
: init-sdl ( width height bpp flags -- )
SDL_INIT_EVERYTHING SDL_Init sdl-error
init-keyboard init-surface init-ttf ;
: with-screen ( width height bpp flags quot -- )
#! Set up SDL graphics and call the quotation.
[ [ >r init-sdl r> call ] [ SDL_Quit ] cleanup ] with-scope ;
inline
: rgb ( [ r g b ] -- n )
first3
@ -53,9 +94,9 @@ SYMBOL: bpp
] repeat
] repeat drop ; inline
: must-lock-surface? ( surface -- ? )
: must-lock-surface? ( -- ? )
#! This is a macro in SDL_video.h.
dup surface-offset 0 = [
surface get dup surface-offset 0 = [
surface-flags
SDL_HWSURFACE SDL_ASYNCBLIT bitor SDL_RLEACCEL bitor
bitand 0 = not
@ -63,16 +104,28 @@ SYMBOL: bpp
drop t
] if ;
: lock-surface ( -- )
surface get SDL_LockSurface sdl-error ;
: unlock-surface ( -- )
surface get SDL_UnlockSurface ;
: with-surface ( quot -- )
#! Execute a quotation, locking the current surface if it
#! is required (eg, hardware surface).
[
surface get dup must-lock-surface? [
dup SDL_LockSurface drop slip dup SDL_UnlockSurface
] [
slip
] if SDL_Flip drop
] with-scope ; inline
must-lock-surface? [ lock-surface ] when
call
] [
must-lock-surface? [ unlock-surface ] when
surface get SDL_Flip
] cleanup ; inline
: with-unlocked-surface ( quot -- )
must-lock-surface?
[ unlock-surface call lock-surface ] [ call ] if ; inline
: surface-rect ( x y surface -- rect )
dup surface-w swap surface-h make-rect ;
{{ }} clone open-fonts global set-hash

6
library/ui/buttons.factor
View File

@ -5,15 +5,15 @@ USING: gadgets gadgets-borders gadgets-layouts gadgets-theme
generic io kernel lists math namespaces sdl sequences sequences
styles threads ;
: button-down? ( n -- ? ) hand hand-buttons member? ;
: button-down? ( n -- ? ) hand get hand-buttons member? ;
: mouse-over? ( gadget -- ? ) hand hand-gadget child? ;
: mouse-over? ( gadget -- ? ) hand get hand-gadget child? ;
: button-pressed? ( button -- ? )
#! Return true if the mouse was clicked on the button, and
#! is currently over the button.
dup mouse-over? 1 button-down? and
[ hand hand-clicked child? ] [ drop f ] if ;
[ hand get hand-clicked child? ] [ drop f ] if ;
: button-update ( button -- )
dup dup mouse-over? rollover set-paint-prop

6
library/ui/editors.factor
View File

@ -66,7 +66,7 @@ TUPLE: editor line caret ;
] with-editor ;
: click-editor ( editor -- )
dup hand relative first over set-caret-x request-focus ;
dup hand get relative first over set-caret-x request-focus ;
: popup-location ( editor -- loc )
dup screen-loc swap editor-caret rect-extent nip v+ ;
@ -91,7 +91,7 @@ TUPLE: editor line caret ;
}@ cond ;
: editor-actions ( editor -- )
[
{{
[[ [ gain-focus ] [ focus-editor ] ]]
[[ [ lose-focus ] [ unfocus-editor ] ]]
[[ [ button-down 1 ] [ click-editor ] ]]
@ -109,7 +109,7 @@ TUPLE: editor line caret ;
[[ [ "END" ] [ [ << document-elt >> next-elt ] with-editor ] ]]
[[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]
[[ [ "TAB" ] [ do-completion ] ]]
] swap add-actions ;
}} add-actions ;
C: editor ( text -- )
dup gadget-delegate

29
library/ui/events.factor
View File

@ -2,49 +2,34 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: arrays alien gadgets-layouts generic kernel lists math
namespaces sdl sequences ;
namespaces sdl sequences strings ;
GENERIC: handle-event ( event -- )
M: object handle-event ( event -- )
drop ;
M: quit-event handle-event ( event -- )
drop f world get set-world-running? ;
M: resize-event handle-event ( event -- )
dup resize-event-w swap resize-event-h
[ 0 3array world get set-gadget-dim ] 2keep
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
world get relayout ;
: button-gesture ( button gesture -- )
swap add hand hand-clicked handle-gesture drop ;
swap add hand get hand-clicked handle-gesture drop ;
M: button-down-event handle-event ( event -- )
button-event-button dup hand button/
button-event-button dup hand get button/
[ button-down ] button-gesture ;
M: button-up-event handle-event ( event -- )
button-event-button dup hand button\
button-event-button dup hand get button\
[ button-up ] button-gesture ;
: motion-event-loc ( event -- loc )
dup motion-event-x swap motion-event-y 0 3array ;
M: motion-event handle-event ( event -- )
motion-event-loc hand move-hand ;
: control-char? ( ch -- ? )
"\0\e\r\u0008\u007f" member? ;
M: key-down-event handle-event ( event -- )
dup keyboard-event>binding
hand hand-focus handle-gesture [
keyboard-event-unicode dup control-char? [
hand get hand-focus handle-gesture [
keyboard-event-unicode dup control? [
drop
] [
hand hand-focus user-input drop
hand get hand-focus user-input drop
] if
] [
drop

36
library/ui/fonts.factor
View File

@ -4,42 +4,6 @@ IN: gadgets
USING: alien arrays errors hashtables io kernel lists namespaces
sdl sequences styles ;
: ttf-name ( font style -- name )
cons {{
[[ [[ "Monospaced" plain ]] "VeraMono" ]]
[[ [[ "Monospaced" bold ]] "VeraMoBd" ]]
[[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]]
[[ [[ "Monospaced" italic ]] "VeraMoIt" ]]
[[ [[ "Sans Serif" plain ]] "Vera" ]]
[[ [[ "Sans Serif" bold ]] "VeraBd" ]]
[[ [[ "Sans Serif" bold-italic ]] "VeraBI" ]]
[[ [[ "Sans Serif" italic ]] "VeraIt" ]]
[[ [[ "Serif" plain ]] "VeraSe" ]]
[[ [[ "Serif" bold ]] "VeraSeBd" ]]
[[ [[ "Serif" bold-italic ]] "VeraBI" ]]
[[ [[ "Serif" italic ]] "VeraIt" ]]
}} hash ;
: ttf-path ( name -- string )
[ "/fonts/" % % ".ttf" % ] "" make resource-path ;
: open-font ( { font style ptsize } -- alien )
first3 >r ttf-name ttf-path r> TTF_OpenFont
dup alien-address 0 = [ SDL_GetError throw ] when ;
SYMBOL: open-fonts
: lookup-font ( font style ptsize -- font )
3array open-fonts get [ open-font ] cache ;
global [ open-fonts nest drop ] bind
: ttf-init ( -- )
TTF_Init sdl-error
global [
open-fonts [ [ cdr expired? not ] hash-subset ] change
] bind ;
: gadget-font ( gadget -- font )
[ font paint-prop ] keep
[ font-style paint-prop ] keep

12
library/ui/gestures.factor
View File

@ -7,11 +7,15 @@ sequences ;
: action ( gadget gesture -- quot )
swap gadget-gestures ?hash ;
: set-action ( gadget quot gesture -- )
pick gadget-gestures ?set-hash swap set-gadget-gestures ;
: init-gestures ( gadget -- gestures )
dup gadget-gestures
[ ] [ {{ }} clone dup rot set-gadget-gestures ] ?if ;
: add-actions ( alist gadget -- )
swap [ unswons set-action ] each-with ;
: set-action ( gadget quot gesture -- )
rot init-gestures set-hash ;
: add-actions ( gadget hash -- )
dup [ >r init-gestures r> hash-update ] [ 2drop ] if ;
: handle-gesture* ( gesture gadget -- ? )
tuck gadget-gestures ?hash dup [ call f ] [ 2drop t ] if ;

29
library/ui/hand.factor
View File

@ -5,21 +5,16 @@ USING: alien generic io kernel lists math matrices namespaces
prettyprint sdl sequences vectors ;
! The hand is a special gadget that holds mouse position and
! mouse button click state. The hand's parent is the world, but
! it is special in that the world does not list it as part of
! its contents. Some comments on the slots:
! mouse button click state.
! Some comments on the slots:
! - hand-gadget is the gadget under the mouse position
! - hand-clicked is the most recently clicked gadget
! - hand-focus is the gadget holding keyboard focus
TUPLE: hand click-loc click-rel clicked buttons gadget focus ;
C: hand ( world -- hand )
dup gadget-delegate
{ } clone over set-hand-buttons
[ set-gadget-parent ] 2keep
[ set-hand-gadget ] keep ;
: hand world get world-hand ;
C: hand ( -- hand )
dup gadget-delegate { } clone over set-hand-buttons ;
: button/ ( n hand -- )
dup hand-gadget over set-hand-clicked
@ -54,16 +49,6 @@ C: hand ( world -- hand )
swap fire-motion
[ mouse-enter ] swap each-gesture ;
: move-hand ( loc hand -- )
dup hand-gadget parents-down >r
2dup set-rect-loc
[ >r world get pick-up r> set-hand-gadget ] keep
dup hand-gadget parents-down r> hand-gestures ;
: update-hand ( hand -- )
#! Called when a gadget is removed or added.
dup rect-loc swap move-hand ;
: focus-gestures ( new old -- )
drop-prefix
reverse [ lose-focus ] swap each-gesture
@ -71,8 +56,8 @@ C: hand ( world -- hand )
: request-focus ( gadget -- )
focusable-child
hand dup hand-focus parents-down >r
hand get dup hand-focus parents-down >r
dupd set-hand-focus parents-down r> focus-gestures ;
: drag-loc ( gadget -- loc )
hand [ relative ] keep hand-click-rel v- ;
hand get [ relative ] keep hand-click-rel v- ;

6
library/ui/load.factor
View File

@ -4,10 +4,11 @@ USING: kernel parser sequences io ;
"/library/ui/layouts.factor"
"/library/ui/hierarchy.factor"
"/library/ui/paint.factor"
"/library/ui/theme.factor"
"/library/ui/world.factor"
"/library/ui/gestures.factor"
"/library/ui/theme.factor"
"/library/ui/hand.factor"
"/library/ui/events.factor"
"/library/ui/world.factor"
"/library/ui/fonts.factor"
"/library/ui/text.factor"
"/library/ui/borders.factor"
@ -15,7 +16,6 @@ USING: kernel parser sequences io ;
"/library/ui/labels.factor"
"/library/ui/buttons.factor"
"/library/ui/line-editor.factor"
"/library/ui/events.factor"
"/library/ui/sliders.factor"
"/library/ui/scrolling.factor"
"/library/ui/menus.factor"

6
library/ui/menus.factor
View File

@ -6,7 +6,7 @@ gadgets-labels gadgets-theme generic kernel lists math
namespaces sequences ;
: retarget-drag ( -- )
hand [ rect-loc world get pick-up ] keep
hand get [ rect-loc world get pick-up ] keep
2dup hand-clicked eq? [
2dup set-hand-clicked dup update-hand
] unless 2drop ;
@ -26,9 +26,9 @@ namespaces sequences ;
>r dup dup show-glass r>
menu-loc swap set-rect-loc
world get world-glass dup menu-actions
hand set-hand-clicked ;
hand get set-hand-clicked ;
: show-hand-menu ( menu -- ) hand rect-loc show-menu ;
: show-hand-menu ( menu -- ) hand get rect-loc show-menu ;
: menu-items ( assoc -- pile )
#! Given an association list mapping labels to quotations.

9
library/ui/paint.factor
View File

@ -41,8 +41,15 @@ GENERIC: draw-gadget* ( gadget -- )
2drop f
] if ;
: init-paint ( gadget -- gestures )
dup gadget-paint
[ ] [ {{ }} clone dup rot set-gadget-paint ] ?if ;
: set-paint-prop ( gadget value key -- )
pick gadget-paint ?set-hash swap set-gadget-paint ;
rot init-paint set-hash ;
: add-paint ( gadget hash -- )
dup [ >r init-paint r> hash-update ] [ 2drop ] if ;
: fg ( gadget -- color )
dup reverse-video paint-prop

15
library/ui/panes.factor
View File

@ -2,13 +2,12 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-presentations
DEFER: <presentation>
DEFER: <input-button>
DEFER: gadget.
IN: gadgets-panes
USING: arrays gadgets gadgets-editors gadgets-labels
gadgets-layouts gadgets-scrolling gadgets-theme generic
hashtables io kernel line-editor lists math namespaces
USING: arrays gadgets gadgets-buttons gadgets-editors
gadgets-labels gadgets-layouts gadgets-scrolling gadgets-theme
generic hashtables io kernel line-editor lists math namespaces
prettyprint sequences strings styles threads ;
! A pane is an area that can display text.
@ -57,6 +56,10 @@ SYMBOL: structured-input
: replace-input ( string pane -- )
pane-input set-editor-text ;
: <input-button> ( string -- button )
dup <label> swap [ nip pane get replace-input ] curry
<roll-button> ;
: print-input ( string pane -- )
[
<input-button> dup bold font-style set-paint-prop gadget.
@ -71,13 +74,13 @@ SYMBOL: structured-input
dup pane-output clear-incremental pane-current clear-gadget ;
: pane-actions ( line -- )
[
{{
[[ [ button-down 1 ] [ pane-input [ click-editor ] when* ] ]]
[[ [ "RETURN" ] [ pane-return ] ]]
[[ [ "UP" ] [ pane-input [ [ history-prev ] with-editor ] when* ] ]]
[[ [ "DOWN" ] [ pane-input [ [ history-next ] with-editor ] when* ] ]]
[[ [ "CTRL" "l" ] [ pane get pane-clear ] ]]
] swap add-actions ;
}} add-actions ;
C: pane ( input? scrolls? -- pane )
#! You can create output-only panes. If the scrolls flag is

6
library/ui/presentations.factor
View File

@ -27,15 +27,11 @@ SYMBOL: commands
: <command-button> ( gadget object -- button )
[ nip command-menu ] curry <menu-button> ;
: <input-button> ( string -- button )
dup <label> swap [ nip pane get replace-input ] curry
<roll-button> ;
: init-commands ( gadget -- gadget )
dup presented paint-prop [ <command-button> ] when* ;
: <styled-label> ( style text -- label )
<label> swap dup [ alist>hash ] when over set-gadget-paint ;
<label> dup rot dup [ alist>hash ] when add-paint ;
: <presentation> ( style text -- presentation )
gadget pick assoc dup

2
library/ui/sliders.factor
View File

@ -66,7 +66,7 @@ SYMBOL: slider-changed
[ slider-page * ] keep slide-by ;
: elevator-click ( elevator -- )
dup hand relative >r find-slider r>
dup hand get relative >r find-slider r>
over slider-vector v.
over screen>slider over slider-value - sgn
swap slide-by-page ;

9
library/ui/text.factor
View File

@ -5,11 +5,10 @@ USING: alien hashtables io kernel lists math namespaces sdl
sequences strings styles ;
: draw-surface ( x y surface -- )
surface get SDL_UnlockSurface
[ [ surface-rect ] keep swap surface get 0 0 ] keep
surface-rect swap rot SDL_UpperBlit drop
surface get dup must-lock-surface?
[ SDL_LockSurface ] when drop ;
[
[ [ surface-rect ] keep swap surface get 0 0 ] keep
surface-rect swap rot SDL_UpperBlit drop
] with-unlocked-surface ;
: filter-nulls ( str -- str )
[ dup 0 = [ drop CHAR: \s ] when ] map ;

2
library/ui/theme.factor
View File

@ -61,4 +61,4 @@ USING: gadgets kernel styles ;
[[ font "Monospaced" ]]
[[ font-size 12 ]]
[[ font-style plain ]]
}} clone swap set-gadget-paint ;
}} add-paint ;

34
library/ui/ui.factor
View File

@ -1,41 +1,41 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: gadgets-layouts gadgets-listener gadgets-theme generic
USING: errors gadgets-layouts gadgets-listener gadgets-theme generic
help io kernel listener lists math memory namespaces prettyprint
sdl sequences shells styles threads words ;
: init-world
ttf-init
global [
<world> world set
@{ 800 600 0 }@ world get set-gadget-dim
world get world-theme
world get clear-gadget
<gadget> dup solid-interior add-layer
listener-application
] bind ;
SYMBOL: first-time
global [ first-time on ] bind
global [
<world> world set
world get world-theme
<hand> hand set
@{ 800 600 0 }@ world get set-gadget-dim
first-time on
] bind
: ?init-world
first-time get [ init-world first-time off ] when ;
: ui-title
[ "Factor " % version % " - " % image % ] "" make ;
: check-running
world get [
dup world-running?
[ "The UI is already running" throw ] when
] when* ;
IN: shells
: ui ( -- )
#! Start the Factor graphics subsystem with the given screen
#! dimensions.
ttf-init
?init-world
world get rect-dim first2 0 SDL_RESIZABLE [
[
ui-title dup SDL_WM_SetCaption
start-world
run-world
] with-screen
] with-scope ;
check-running
world get rect-dim first2 0 SDL_RESIZABLE
[ ?init-world run-world ] with-screen ;

54
library/ui/world.factor
View File

@ -9,18 +9,14 @@ strings styles threads ;
! gadgets are contained in. The current world is stored in the
! world variable. The invalid slot is a list of gadgets that
! need to be layout.
TUPLE: world running? hand glass invalid ;
DEFER: <hand>
DEFER: update-hand
TUPLE: world running? glass invalid ;
: add-layer ( gadget -- )
world get add-gadget ;
C: world ( -- world )
<stack> over set-delegate
t over set-gadget-root?
dup <hand> over set-world-hand ;
t over set-gadget-root? ;
: add-invalid ( gadget -- )
world get [ world-invalid cons ] keep set-world-invalid ;
@ -46,23 +42,53 @@ C: world ( -- world )
: draw-world ( world -- )
[ world-clip clip set draw-gadget ] with-surface ;
DEFER: handle-event
: move-hand ( loc hand -- )
dup hand-gadget parents-down >r
2dup set-rect-loc
[ >r world get pick-up r> set-hand-gadget ] keep
dup hand-gadget parents-down r> hand-gestures ;
: world-step ( -- ? )
M: motion-event handle-event ( event -- )
motion-event-loc hand get move-hand ;
: update-hand ( hand -- )
#! Called when a gadget is removed or added.
dup rect-loc swap move-hand ;
: stop-world ( -- )
f world get set-world-running? ;
: ui-title
[ "Factor " % version % " - " % image % ] "" make ;
: start-world ( -- )
ui-title dup SDL_WM_SetCaption
world get dup relayout t swap set-world-running? ;
: world-step ( -- )
world get dup world-invalid >r layout-world r>
[ dup world-hand update-hand dup draw-world ] when drop ;
[ dup hand get update-hand dup draw-world ] when drop ;
: next-event ( -- event ? ) <event> dup SDL_PollEvent ;
: run-world ( -- )
: world-loop ( -- )
#! Keep polling for events until there are no more events in
#! the queue; then block for the next event.
next-event [
handle-event run-world
handle-event world-loop
] [
drop world-step do-timers
world get world-running? [ 10 sleep run-world ] when
world get world-running? [ 10 sleep world-loop ] when
] if ;
: start-world ( -- )
world get t over set-world-running? relayout ;
: run-world ( -- )
[ start-world world-loop ] [ stop-world ] cleanup ;
M: quit-event handle-event ( event -- )
drop stop-world ;
M: resize-event handle-event ( event -- )
dup resize-event-w swap resize-event-h
[ 0 3array world get set-gadget-dim ] 2keep
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-surface
world get relayout ;