UI cleanup
Slava Pestov
parent
a5c67414d8
commit
4474964873
|
|
@ -1,54 +0,0 @@
|
||||||
IN: gadgets
|
|
||||||
USING: generic kernel namespaces threads ;
|
|
||||||
|
|
||||||
TUPLE: dialog continuation ;
|
|
||||||
|
|
||||||
: dialog-action ( dialog ? -- )
|
|
||||||
over close-tile swap dialog-continuation call ;
|
|
||||||
|
|
||||||
: dialog-ok ( dialog -- ) t dialog-action ;
|
|
||||||
|
|
||||||
: dialog-cancel ( dialog -- ) f dialog-action ;
|
|
||||||
|
|
||||||
: <dialog-buttons> ( -- gadget )
|
|
||||||
<default-shelf>
|
|
||||||
"OK" [ dialog-ok ] <button> over add-gadget
|
|
||||||
"Cancel" [ dialog-cancel ] <button> over add-gadget ;
|
|
||||||
|
|
||||||
: dialog-actions ( dialog -- )
|
|
||||||
dup [ dialog-ok ] dup set-action
|
|
||||||
[ dialog-cancel ] dup set-action ;
|
|
||||||
|
|
||||||
C: dialog ( content continuation -- gadget )
|
|
||||||
[ set-dialog-continuation ] keep
|
|
||||||
[ <empty-gadget> swap set-delegate ] keep
|
|
||||||
[
|
|
||||||
>r <default-pile>
|
|
||||||
[ add-gadget ] keep
|
|
||||||
[ <dialog-buttons> swap add-gadget ] keep
|
|
||||||
r> add-gadget
|
|
||||||
] keep
|
|
||||||
[ dialog-actions ] keep ;
|
|
||||||
|
|
||||||
: dialog ( content title -- ? )
|
|
||||||
#! Show a modal dialog and wait until OK or Cancel is
|
|
||||||
#! clicked. Outputs a true value if OK was clicked.
|
|
||||||
[ swap >r <dialog> r> tile stop ] callcc1 2nip ;
|
|
||||||
|
|
||||||
TUPLE: prompt editor ;
|
|
||||||
|
|
||||||
C: prompt ( prompt -- gadget )
|
|
||||||
0 default-gap 0 <pile> over set-delegate
|
|
||||||
[ >r <label> r> add-gadget ] keep
|
|
||||||
"" <editor> over set-prompt-editor
|
|
||||||
dup prompt-editor line-border over add-gadget ;
|
|
||||||
|
|
||||||
: input-dialog ( prompt -- input )
|
|
||||||
#! Show an input dialog and resume the current continuation
|
|
||||||
#! when the user clicks OK or Cancel. If they click Cancel,
|
|
||||||
#! push f.
|
|
||||||
<prompt> dup "Input" dialog [
|
|
||||||
prompt-editor editor-text
|
|
||||||
] [
|
|
||||||
drop f
|
|
||||||
] ifte ;
|
|
||||||
|
|
@ -1,98 +0,0 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
|
||||||
IN: gadgets
|
|
||||||
USING: errors gadgets generic hashtables kernel kernel-internals
|
|
||||||
lists namespaces sequences strings unparser vectors words ;
|
|
||||||
|
|
||||||
: label-box ( list -- gadget )
|
|
||||||
0 0 0 <pile> swap [ <presentation> over add-gadget ] each ;
|
|
||||||
|
|
||||||
: unparse* ( obj -- str ) dup string? [ unparse ] unless ;
|
|
||||||
|
|
||||||
: sort-sheet ( assoc -- assoc )
|
|
||||||
#! Sort an association list whose keys are arbitrary objects
|
|
||||||
[ 2car swap unparse* swap unparse* string> ] sort ;
|
|
||||||
|
|
||||||
: alist>sheet ( assoc -- sheet )
|
|
||||||
unzip swap
|
|
||||||
<default-shelf>
|
|
||||||
[ >r label-box r> add-gadget ] keep
|
|
||||||
[ >r label-box r> add-gadget ] keep ;
|
|
||||||
|
|
||||||
: <titled> ( gadget title -- gadget )
|
|
||||||
0 10 0 <shelf>
|
|
||||||
[ >r <label> r> add-gadget ] keep
|
|
||||||
[ add-gadget ] keep ;
|
|
||||||
|
|
||||||
: top-sheet ( obj -- sheet )
|
|
||||||
dup class word-name <label> "Class:" <titled>
|
|
||||||
swap unparse <label> "Object:" <titled>
|
|
||||||
<line-pile> [ add-gadget ] keep [ add-gadget ] keep ;
|
|
||||||
|
|
||||||
: object>alist ( obj -- assoc )
|
|
||||||
dup class "slots" word-prop [
|
|
||||||
second [ execute ] keep swons
|
|
||||||
] map-with ;
|
|
||||||
|
|
||||||
: slot-sheet ( obj -- sheet )
|
|
||||||
object>alist sort-sheet alist>sheet "Slots:" <titled> ;
|
|
||||||
|
|
||||||
GENERIC: custom-sheet ( obj -- gadget )
|
|
||||||
|
|
||||||
: <inspector> ( obj -- gadget )
|
|
||||||
0 10 0 <pile>
|
|
||||||
over top-sheet over add-gadget
|
|
||||||
over slot-sheet over add-gadget
|
|
||||||
swap custom-sheet over add-gadget ;
|
|
||||||
|
|
||||||
M: object custom-sheet drop <empty-gadget> ;
|
|
||||||
|
|
||||||
M: list custom-sheet ( list -- gadget )
|
|
||||||
[ length count ] keep zip alist>sheet "Elements:" <titled> ;
|
|
||||||
|
|
||||||
M: array custom-sheet ( array -- gadget )
|
|
||||||
>list custom-sheet ;
|
|
||||||
|
|
||||||
M: vector custom-sheet ( array -- gadget )
|
|
||||||
>list custom-sheet ;
|
|
||||||
|
|
||||||
M: hashtable custom-sheet ( array -- gadget )
|
|
||||||
hash>alist sort-sheet alist>sheet "Entries:" <titled> ;
|
|
||||||
|
|
||||||
M: word custom-sheet ( word -- gadget )
|
|
||||||
word-props <inspector> empty-border "Properties:" <titled> ;
|
|
||||||
|
|
||||||
M: tuple custom-sheet ( tuple -- gadget )
|
|
||||||
delegate [
|
|
||||||
<inspector> empty-border "Delegate:" <titled>
|
|
||||||
] [
|
|
||||||
<empty-gadget>
|
|
||||||
] ifte* ;
|
|
||||||
|
|
||||||
! We ensure that only one inspector is open for each object.
|
|
||||||
SYMBOL: inspectors
|
|
||||||
|
|
||||||
: ensure-ui
|
|
||||||
world get dup [ world-running? ] when [
|
|
||||||
"Inspector cannot be used if UI not running." throw
|
|
||||||
] unless ;
|
|
||||||
|
|
||||||
: inspector ( obj -- gadget )
|
|
||||||
#! Return an existing inspector gadget for this object, or
|
|
||||||
#! create a new one.
|
|
||||||
dup inspectors get assq [ ] [
|
|
||||||
dup <inspector>
|
|
||||||
[ swap inspectors [ acons ] change ] keep
|
|
||||||
] ?ifte ;
|
|
||||||
|
|
||||||
: inspector-tile ( obj -- tile )
|
|
||||||
inspector <scroller> "Inspector" <tile> ;
|
|
||||||
|
|
||||||
: inspect ( obj -- )
|
|
||||||
#! Show an inspector for the object. The inspector lists
|
|
||||||
#! slots and entries in collections.
|
|
||||||
ensure-ui global [
|
|
||||||
inspector-tile world get add-gadget
|
|
||||||
] bind ;
|
|
||||||
|
|
||||||
global [ inspectors off ] bind
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: generic kernel lists math namespaces sdl io sequences ;
|
USING: generic hashtables io kernel lists math namespaces sdl
|
||||||
|
sequences ;
|
||||||
|
|
||||||
! A label gadget draws a string.
|
! A label gadget draws a string.
|
||||||
TUPLE: label text ;
|
TUPLE: label text ;
|
||||||
|
|
@ -17,3 +18,11 @@ M: label pref-size ( label -- w h )
|
||||||
|
|
||||||
M: label draw-shape ( label -- )
|
M: label draw-shape ( label -- )
|
||||||
[ label-text ] keep [ draw-string ] with-trans ;
|
[ label-text ] keep [ draw-string ] with-trans ;
|
||||||
|
|
||||||
|
: <styled-label> ( style text -- label )
|
||||||
|
<label> swap [
|
||||||
|
unswons [
|
||||||
|
[[ "fg" foreground ]]
|
||||||
|
[[ "bg" background ]]
|
||||||
|
] assoc swons
|
||||||
|
] map alist>hash over set-gadget-paint ;
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,6 @@
|
||||||
USING: kernel parser sequences io ;
|
USING: kernel parser sequences io ;
|
||||||
[
|
[
|
||||||
|
"/library/ui/colors.factor"
|
||||||
"/library/ui/shapes.factor"
|
"/library/ui/shapes.factor"
|
||||||
"/library/ui/points.factor"
|
"/library/ui/points.factor"
|
||||||
"/library/ui/rectangles.factor"
|
"/library/ui/rectangles.factor"
|
||||||
|
|
@ -29,11 +30,7 @@ USING: kernel parser sequences io ;
|
||||||
"/library/ui/presentations.factor"
|
"/library/ui/presentations.factor"
|
||||||
"/library/ui/tiles.factor"
|
"/library/ui/tiles.factor"
|
||||||
"/library/ui/splitters.factor"
|
"/library/ui/splitters.factor"
|
||||||
"/library/ui/panes.factor"
|
|
||||||
"/library/ui/dialogs.factor"
|
|
||||||
"/library/ui/inspector.factor"
|
|
||||||
"/library/ui/init-world.factor"
|
"/library/ui/init-world.factor"
|
||||||
"/library/ui/tool-menus.factor"
|
|
||||||
"/library/ui/ui.factor"
|
"/library/ui/ui.factor"
|
||||||
] [
|
] [
|
||||||
dup print run-resource
|
dup print run-resource
|
||||||
|
|
|
||||||
|
|
@ -1,93 +0,0 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
|
||||||
IN: gadgets
|
|
||||||
USING: generic kernel line-editor listener lists math namespaces
|
|
||||||
sequences io strings threads ;
|
|
||||||
|
|
||||||
! A pane is an area that can display text.
|
|
||||||
|
|
||||||
! output: pile
|
|
||||||
! current: shelf
|
|
||||||
! input: editor
|
|
||||||
TUPLE: pane output active current input continuation ;
|
|
||||||
|
|
||||||
: add-output 2dup set-pane-output add-gadget ;
|
|
||||||
: add-input 2dup set-pane-input add-gadget ;
|
|
||||||
|
|
||||||
: <active-line> ( input current -- line )
|
|
||||||
<line-shelf> [ add-gadget ] keep [ add-gadget ] keep ;
|
|
||||||
|
|
||||||
: init-active-line ( pane -- )
|
|
||||||
dup pane-active [ unparent ] when*
|
|
||||||
[ dup pane-input swap pane-current <active-line> ] keep
|
|
||||||
2dup set-pane-active add-gadget ;
|
|
||||||
|
|
||||||
: pane-paint ( pane -- )
|
|
||||||
[[ "Monospaced" 12 ]] font set-paint-prop ;
|
|
||||||
|
|
||||||
: pop-continuation ( pane -- quot )
|
|
||||||
dup pane-continuation f rot set-pane-continuation ;
|
|
||||||
|
|
||||||
: pane-return ( pane -- )
|
|
||||||
[
|
|
||||||
pane-input [
|
|
||||||
commit-history line-text get line-clear
|
|
||||||
] with-editor
|
|
||||||
] keep
|
|
||||||
2dup stream-write "\n" over stream-write
|
|
||||||
pop-continuation in-thread drop ;
|
|
||||||
|
|
||||||
: pane-actions ( line -- )
|
|
||||||
[
|
|
||||||
[[ [ button-down 1 ] [ pane-input click-editor ] ]]
|
|
||||||
[[ [ "RETURN" ] [ pane-return ] ]]
|
|
||||||
[[ [ "UP" ] [ pane-input [ history-prev ] with-editor ] ]]
|
|
||||||
[[ [ "DOWN" ] [ pane-input [ history-next ] with-editor ] ]]
|
|
||||||
] swap add-actions ;
|
|
||||||
|
|
||||||
C: pane ( -- pane )
|
|
||||||
<line-pile> over set-delegate
|
|
||||||
<line-pile> over add-output
|
|
||||||
"" <label> over set-pane-current
|
|
||||||
"" <editor> over set-pane-input
|
|
||||||
dup init-active-line
|
|
||||||
dup pane-paint
|
|
||||||
dup pane-actions ;
|
|
||||||
|
|
||||||
: pane-write-1 ( text pane -- )
|
|
||||||
>r <label> r> pane-current add-gadget ;
|
|
||||||
|
|
||||||
: pane-terpri ( pane -- )
|
|
||||||
dup pane-current over pane-output add-gadget
|
|
||||||
<line-shelf> over set-pane-current init-active-line ;
|
|
||||||
|
|
||||||
: pane-write ( pane list -- )
|
|
||||||
2dup car swap pane-write-1
|
|
||||||
cdr dup [
|
|
||||||
over pane-terpri pane-write
|
|
||||||
] [
|
|
||||||
2drop
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
! Panes are streams.
|
|
||||||
M: pane stream-flush ( stream -- ) relayout ;
|
|
||||||
M: pane stream-auto-flush ( stream -- ) stream-flush ;
|
|
||||||
|
|
||||||
M: pane stream-readln ( stream -- line )
|
|
||||||
[ over set-pane-continuation stop ] callcc1 nip ;
|
|
||||||
|
|
||||||
M: pane stream-write-attr ( string style stream -- )
|
|
||||||
[ nip swap "\n" split pane-write ] keep scroll>bottom ;
|
|
||||||
|
|
||||||
M: pane stream-close ( stream -- ) drop ;
|
|
||||||
|
|
||||||
: <console> ( -- pane )
|
|
||||||
<pane> dup
|
|
||||||
[ [ clear print-banner listener ] in-thread ] with-stream
|
|
||||||
<scroller> ;
|
|
||||||
|
|
||||||
: console ( -- )
|
|
||||||
#! Open an UI console window.
|
|
||||||
<console> "Listener" <tile> world get [
|
|
||||||
shape-size rect> 3/4 * >rect rot resize-gadget
|
|
||||||
] 2keep add-gadget ;
|
|
||||||
|
|
@ -1,18 +0,0 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
|
||||||
IN: gadgets
|
|
||||||
USING: kernel memory namespaces io ;
|
|
||||||
|
|
||||||
SYMBOL: root-menu
|
|
||||||
|
|
||||||
: show-root-menu ( -- )
|
|
||||||
root-menu get <menu> show-menu ;
|
|
||||||
|
|
||||||
[
|
|
||||||
[[ "Listener" [ console ] ]]
|
|
||||||
[[ "Globals" [ global inspect ] ]]
|
|
||||||
[[ "Save image" [ save ] ]]
|
|
||||||
[[ "Exit" [ f world get set-world-running? ] ]]
|
|
||||||
] root-menu set
|
|
||||||
|
|
||||||
! world get [ drop show-root-menu ] [ button-down 1 ] set-action
|
|
||||||
|
|
@ -3,18 +3,6 @@
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: kernel namespaces sdl sequences ;
|
USING: kernel namespaces sdl sequences ;
|
||||||
|
|
||||||
: title ( -- str )
|
|
||||||
"Factor " version append ;
|
|
||||||
|
|
||||||
SYMBOL: first-time?
|
|
||||||
global [ first-time? on ] bind
|
|
||||||
|
|
||||||
: first-time ( -- )
|
|
||||||
first-time? get [
|
|
||||||
world get gadget-paint [ console ] bind
|
|
||||||
global [ first-time? off ] bind
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
IN: shells
|
IN: shells
|
||||||
|
|
||||||
: ui ( -- )
|
: ui ( -- )
|
||||||
|
|
@ -22,7 +10,7 @@ IN: shells
|
||||||
#! dimensions.
|
#! dimensions.
|
||||||
world get shape-size 0 SDL_RESIZABLE [
|
world get shape-size 0 SDL_RESIZABLE [
|
||||||
0 x set 0 y set [
|
0 x set 0 y set [
|
||||||
title dup SDL_WM_SetCaption first-time
|
"Factor " version append dup SDL_WM_SetCaption
|
||||||
start-world
|
start-world
|
||||||
run-world
|
run-world
|
||||||
] with-screen
|
] with-screen
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue