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.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
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.
|
||||
TUPLE: label text ;
|
||||
|
|
@ -17,3 +18,11 @@ M: label pref-size ( label -- w h )
|
|||
|
||||
M: label draw-shape ( label -- )
|
||||
[ 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 ;
|
||||
[
|
||||
"/library/ui/colors.factor"
|
||||
"/library/ui/shapes.factor"
|
||||
"/library/ui/points.factor"
|
||||
"/library/ui/rectangles.factor"
|
||||
|
|
@ -29,11 +30,7 @@ USING: kernel parser sequences io ;
|
|||
"/library/ui/presentations.factor"
|
||||
"/library/ui/tiles.factor"
|
||||
"/library/ui/splitters.factor"
|
||||
"/library/ui/panes.factor"
|
||||
"/library/ui/dialogs.factor"
|
||||
"/library/ui/inspector.factor"
|
||||
"/library/ui/init-world.factor"
|
||||
"/library/ui/tool-menus.factor"
|
||||
"/library/ui/ui.factor"
|
||||
] [
|
||||
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
|
||||
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
|
||||
|
||||
: ui ( -- )
|
||||
|
|
@ -22,7 +10,7 @@ IN: shells
|
|||
#! dimensions.
|
||||
world get shape-size 0 SDL_RESIZABLE [
|
||||
0 x set 0 y set [
|
||||
title dup SDL_WM_SetCaption first-time
|
||||
"Factor " version append dup SDL_WM_SetCaption
|
||||
start-world
|
||||
run-world
|
||||
] with-screen
|
||||
|
|
|
|||
Loading…
Reference in New Issue