+++ /dev/null
-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 ;
+++ /dev/null
-! 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
! 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 ;
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 ;
USING: kernel parser sequences io ;
[
+ "/library/ui/colors.factor"
"/library/ui/shapes.factor"
"/library/ui/points.factor"
"/library/ui/rectangles.factor"
"/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
+++ /dev/null
-! 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 ;
+++ /dev/null
-! 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
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 ( -- )
#! 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