- off-by-one error in pick-up?\r
- closing ui does not stop timers\r
- adding/removing timers automatically for animated gadgets\r
-- fix listener prompt display after presentation commands invoked\r
- theme abstraction in ui\r
- menu dragging\r
- fix up the min thumb size hack\r
- gaps in pack layout\r
- find out why so many small bignums get consed\r
- faster mouse tracking\r
-- an interior paint that is only painted on rollover and mouse press;\r
- use it for menu items. give menus a gradient background\r
- scroll bar: more intuitive behavior when clicking inside the elevator\r
- nicer scrollbars with up/down buttons\r
- icons\r
M: general-list tutorial-line\r
car dup <label> dup rot [ pane get pane-input set-editor-text drop ] cons\r
button-gestures\r
+ dup roll-button-theme\r
dup "Monospaced" font set-paint-prop ;\r
\r
: <page> ( list -- gadget )\r
\r
: tutorial ( -- )\r
<tutorial> gadget. ;\r
+\r
+: <tutorial-button>\r
+ "Tutorial" [ drop [ tutorial ] pane get pane-call ] <button> ;\r
+\r
M: comment pprint* ( ann -- )
"( " over comment-text " )" append3
- swap comment-node presented swons unit format ;
+ swap comment-node presented swons unit text ;
: comment, ( ? node text -- )
rot [ <comment> , ] [ 2drop ] ifte ;
dup mouse-over?
[ [ action ] swap handle-gesture drop ] [ drop ] ifte ;
+: button-theme ( button -- )
+ dup { 216 216 216 } background set-paint-prop
+ dup f reverse-video set-paint-prop
+ << solid f >> interior set-paint-prop ;
+
+: roll-button-theme ( button -- )
+ dup f reverse-video set-paint-prop
+ dup <rollover-only> interior set-paint-prop
+ <rollover-only> boundary set-paint-prop ;
+
: button-action ( action -- quot )
[ [ swap handle-gesture drop ] cons ] [ [ drop ] ] ifte* ;
: button-gestures ( button quot -- )
- over f reverse-video set-paint-prop
- over << solid f >> interior set-paint-prop
dupd [ action ] set-action
dup [ dup button-update button-clicked ] [ button-up 1 ] set-action
dup [ button-update ] [ button-down 1 ] set-action
dup [ button-update ] [ mouse-enter ] set-action
[ drop ] [ drag 1 ] set-action ;
+: (button) ( label quot -- button )
+ >r <label> bevel-border dup r> button-gestures ;
+
: <button> ( label quot -- button )
- >r
- <label> bevel-border
- dup { 216 216 216 } background set-paint-prop
- dup
- r> button-gestures ;
+ (button) dup button-theme ;
+
+: <roll-button> ( label quot -- button )
+ (button) dup roll-button-theme ;
<plain-gadget> { 1 1 0 } <border> ;
: <menu-item> ( label quot -- gadget )
- >r <label> menu-item-border dup r> button-gestures ;
+ >r <label> menu-item-border dup roll-button-theme dup
+ r> button-gestures ;
TUPLE: menu ;
uncons \ hide-glass swons <menu-item> swap add-gadget
] each-with ;
+: menu-theme ( menu -- )
+ << gradient f { 1 0 0 } { 240 240 255 } { 216 216 216 } >>
+ interior set-paint-prop ;
+
C: menu ( assoc -- gadget )
#! Given an association list mapping labels to quotations.
[ f line-border swap set-delegate ] keep
0 1 <pile> [ swap add-gadget ] 2keep
- rot assoc>menu dup menu-actions ;
+ rot assoc>menu dup menu-actions
+ dup menu-theme ;
M: f draw-interior 2drop ;
M: f draw-boundary 2drop ;
+! Solid fill/border
TUPLE: solid ;
: rect>screen ( shape -- x1 y1 x2 y2 )
drop >r surface get r> [ rect>screen ] keep
fg rgb rectangleColor ;
+! Rollover only
+TUPLE: rollover-only ;
+
+C: rollover-only << solid f >> over set-delegate ;
+
+M: rollover-only draw-interior ( gadget interior -- )
+ over rollover paint-prop
+ [ delegate draw-interior ] [ 2drop ] ifte ;
+
+M: rollover-only draw-boundary ( gadget boundary -- )
+ over rollover paint-prop
+ [ delegate draw-boundary ] [ 2drop ] ifte ;
+
! Gradient pen
TUPLE: gradient vector from to ;
dup pane-continuation f rot set-pane-continuation ;
: pane-eval ( string pane -- )
- 2dup stream-print pop-continuation in-thread drop ;
+ pop-continuation in-thread drop ;
+
+SYMBOL: structured-input
+
+: elements. ( quot -- )
+ [
+ 1 nesting-limit set
+ 5 length-limit set
+ <block pprint-elements block> t newline
+ ] with-pprint ;
: pane-call ( quot pane -- )
- [ "(Structured input) " write dup . call ] with-stream* ;
+ 2dup [ elements. ] with-stream*
+ >r structured-input global set-hash
+ "structured-input global hash call" r> pane-eval ;
+
+: editor-commit ( editor -- line )
+ #! Add current line to the history, and clear the editor.
+ [ commit-history line-text get line-clear ] with-editor ;
: pane-return ( pane -- )
- [
- pane-input
- [ commit-history line-text get line-clear ] with-editor
- ] keep pane-eval ;
+ [ pane-input editor-commit ] keep
+ 2dup stream-print pane-eval ;
: pane-actions ( line -- )
[
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic hashtables inspector io jedit kernel lists memory
-namespaces parser prettyprint sequences styles vectors words ;
+USING: compiler generic hashtables inference inspector io jedit
+kernel lists memory namespaces parser prettyprint sequences
+styles vectors words ;
SYMBOL: commands
commands get [ first call ] subset-with ;
: command-quot ( presented quot -- quot )
- [ swap literalize , % ] [ ] make
- [ pane get pane-call drop ] cons ;
+ [
+ [ swap literalize , % ] [ ] make ,
+ [ pane get pane-call ] %
+ ] [ ] make ;
: command-menu ( presented -- menu )
dup applicable
<menu> ;
: init-commands ( gadget -- )
+ dup roll-button-theme
dup presented paint-prop dup [
[
\ drop ,
[ drop t ] "Prettyprint" [ . ] define-command
[ drop t ] "Inspect" [ inspect ] define-command
-[ drop t ] "References" [ references inspect ] define-command
+[ drop t ] "Inspect variable" [ get inspect ] define-command
+[ drop t ] "Inspect references" [ references inspect ] define-command
+[ drop t ] "Push on data stack" [ ] define-command
-[ word? ] "See" [ see ] define-command
-[ word? ] "Usage" [ usage . ] define-command
-[ word? ] "jEdit" [ jedit ] define-command
+[ word? ] "See word" [ see ] define-command
+[ word? ] "Word usage" [ usage . ] define-command
+[ word? ] "Open in jEdit" [ jedit ] define-command
+[ word? ] "Reload original source" [ reload ] define-command
+[ compound? ] "Annotate with watchpoint" [ watch ] define-command
+[ compound? ] "Annotate with breakpoint" [ break ] define-command
+[ compound? ] "Annotate with profiling" [ profile ] define-command
+[ word? ] "Compile" [ recompile ] define-command
+[ word? ] "Decompile" [ decompile ] define-command
+[ word? ] "Show stack effect" [ unit infer . ] define-command
+[ word? ] "Show dataflow IR" [ word-def t dataflow. ] define-command
+[ word? ] "Show linear IR" [ precompile ] define-command
-[ [ gadget? ] is? ] "Display" [ gadget. ] define-command
+[ [ gadget? ] is? ] "Display gadget" [ gadget. ] define-command
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: help
-DEFER: tutorial
+DEFER: <tutorial-button>
IN: gadgets
USING: generic help io kernel listener math namespaces
-prettyprint sdl sequences styles threads words ;
+prettyprint sdl sequences styles threads words shells ;
SYMBOL: stack-display
: ui.s ( -- )
stack-display get dup pane-clear [ .s ] with-stream* ;
+: listener-thread
+ pane get [
+ [ ui.s ] listener-hook set <tutorial-button> gadget. tty
+ ] with-stream* ;
+
+: listener-application
+ <pane> dup pane set <scroller>
+ <pane> dup stack-display set <scroller>
+ 5/6 <x-splitter> add-layer
+ [ clear listener-thread ] in-thread
+ pane get request-focus ;
+
: init-world
global [
<world> world set
+ { 700 800 0 } world get set-gadget-dim
{{
[[ background { 255 255 255 } ]]
- [[ rollover-bg { 216 216 255 } ]]
+ [[ rollover-bg { 236 230 232 } ]]
[[ bevel-1 { 160 160 160 } ]]
[[ bevel-2 { 216 216 216 } ]]
[[ foreground { 0 0 0 } ]]
[[ font-size 12 ]]
[[ font-style plain ]]
}} world get set-gadget-paint
-
- { 700 800 0 } world get set-gadget-dim
-
+
<plain-gadget> add-layer
-
- <pane> dup pane set <scroller>
- <pane> dup stack-display set <scroller>
- 5/6 <x-splitter> add-layer
-
- [
- pane get [
- [ ui.s ] listener-hook set
- clear print-banner
- "Tutorial" [ drop [ tutorial ] pane get pane-call ] <button> gadget.
- listener
- ] with-stream
- ] in-thread
- ] bind
-
- pane get request-focus ;
+
+ listener-application
+ ] bind ;
SYMBOL: first-time
: ?init-world
first-time get [ init-world first-time off ] when ;
+
IN: shells
+: ui-title
+ [ "Factor " % version % " - " % "image" get % ] "" make ;
+
: ui ( -- )
#! Start the Factor graphics subsystem with the given screen
#! dimensions.
?init-world
world get rect-dim 2unseq 0 SDL_RESIZABLE [
[
- "Factor " version append dup SDL_WM_SetCaption
+ ui-title dup SDL_WM_SetCaption
start-world
run-world
] with-screen
DEFER: <hand>
DEFER: update-hand
-DEFER: do-timers
+
+: add-layer ( gadget -- )
+ world get add-gadget ;
C: world ( -- world )
<stack> over set-delegate
world get world-invalid
[ pop-invalid [ layout ] each layout-world ] when ;
-: add-layer ( gadget -- )
- world get add-gadget ;
-
: hide-glass ( -- )
world get world-glass unparent f
world get set-world-glass ;