\r
+ ui:\r
\r
+- fix up the min thumb size hack\r
+- scroll bar: more intuitive behavior when clicking inside the elevator\r
+- nicer scrollbars with up/down buttons\r
+- clicking outside menu doesn't close\r
+- only redraw dirty gadgets\r
+- faster mouse tracking\r
+- better menu positioning\r
+\r
- off-by-one error in pick-up?\r
- closing ui does not stop timers\r
- adding/removing timers automatically for animated gadgets\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
-- scroll bar: more intuitive behavior when clicking inside the elevator\r
-- nicer scrollbars with up/down buttons\r
- icons\r
- use incremental strategy for all pack layouts where possible\r
- multiline editing in listener\r
-- better menu positioning\r
-- only redraw dirty gadgets\r
- get stuff in examples dir running in the ui\r
-- opengl rendering\r
- text selection\r
- clipboard support\r
-- clicking outside menu doesn't close\r
\r
+ tutorial:\r
\r
\r
GENERIC: tutorial-line ( object -- gadget )\r
\r
-M: string tutorial-line <label> ;\r
+M: string tutorial-line\r
+ {\r
+ { [ "* " ?head ] [ <slide-title> ] }\r
+ { [ dup "--" = ] [ drop <underline> ] }\r
+ { [ t ] [ <label> ] }\r
+ } cond ;\r
\r
: example-theme\r
dup button-theme\r
"Monospaced" font set-paint-prop ;\r
\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 example-theme ;\r
+ car\r
+ <label> [ label-text pane get pane-input set-editor-text ]\r
+ <roll-button> dup example-theme ;\r
\r
: <page> ( list -- gadget )\r
- 0 1 <pile>\r
- over car <slide-title> over add-gadget\r
- <underline> over add-gadget\r
- swap cdr [ tutorial-line over add-gadget ] each\r
+ [ tutorial-line ] map\r
+ 1 <pile> [ add-gadgets ] keep\r
empty-border ;\r
\r
: tutorial-pages\r
[\r
[\r
- "Factor: a dynamic language"\r
+ "* Factor: a dynamic language"\r
+ "--"\r
"This series of slides presents a quick overview of Factor."\r
""\r
"Factor is interactive, which means you can test out the code"\r
""\r
"http://factor.sourceforge.net"\r
] [\r
- "The view from 10,000 feet"\r
+ "* The view from 10,000 feet"\r
+ "--"\r
"- Everything is an object"\r
"- A word is a basic unit of code"\r
"- Words are identified by names, and organized in vocabularies"\r
"- Code blocks can be passed as parameters to words"\r
"- Word definitions are very short with very high code reuse"\r
] [\r
- "Basic syntax"\r
+ "* Basic syntax"\r
+ "--"\r
"Factor code is made up of whitespace-speparated tokens."\r
"Recall the example from the first slide:"\r
""\r
"The second token (print) is a word."\r
"The string is pushed on the stack, and the print word prints it."\r
] [\r
- "The stack"\r
+ "* The stack"\r
+ "--"\r
"- The stack is like a pile of papers."\r
"- You can ``push'' papers on the top of the pile,"\r
" and ``pop'' papers from the top of the pile."\r
""\r
"Try running it in the listener now."\r
] [\r
- "Postfix arithmetic"\r
+ "* Postfix arithmetic"\r
+ "--"\r
"What happened when you ran it?"\r
""\r
"The two numbers (2 3) are pushed on the stack."\r
"Traditional arithmetic is called infix: 3 + (6 * 2)"\r
"Lets translate this into postfix: 3 6 2 * + ."\r
] [\r
- "Colon definitions"\r
+ "* Colon definitions"\r
+ "--"\r
"We can define new words in terms of existing words."\r
""\r
[ ": twice 2 * ;" ]\r
""\r
[ "3 2 * 2 * ." ]\r
] [\r
- "Stack effects"\r
+ "* Stack effects"\r
+ "--"\r
"When we look at the definition of the ``twice'' word,"\r
"it is intuitively obvious that it takes one value from the stack,"\r
"and leaves one value behind. However, with more complex"\r
"The stack effect of + is ( x y -- x+y )."\r
"The stack effect of . is ( object -- )."\r
] [\r
- "Reading user input"\r
+ "* Reading user input"\r
+ "--"\r
"User input is read using the readln ( -- string ) word."\r
"Note its stack effect; it puts a string on the stack."\r
""\r
[ "\"What is your name?\" print" ]\r
[ "readln \"Hello, \" write print" ]\r
] [\r
- "Shuffle words"\r
+ "* Shuffle words"\r
+ "--"\r
"The word ``twice'' we defined is useless."\r
"Let's try something more useful: squaring a number."\r
""\r
"( object -- object object ), and it does exactly what we"\r
"need. The ``dup'' word is known as a shuffle word."\r
] [\r
- "The squared word"\r
+ "* The squared word"\r
+ "--"\r
"Try entering the following word definition:"\r
""\r
[ ": square ( n -- n*n ) dup * ;" ]\r
"swap ( obj1 obj2 -- obj2 obj1 )"\r
"over ( obj1 obj2 -- obj1 obj2 obj1 )"\r
] [\r
- "Another shuffle example"\r
+ "* Another shuffle example"\r
+ "--"\r
"Now let us write a word that negates a number."\r
"Start by entering the following in the listener"\r
""\r
""\r
[ ": negate ( n -- -n ) 0 swap - ;" ]\r
] [\r
- "Seeing words"\r
+ "* Seeing words"\r
+ "--"\r
"If you have entered every definition in this tutorial,"\r
"you will now have several new colon definitions:"\r
""\r
"Prefixing a word with \\ pushes it on the stack, instead of"\r
"executing it. So the see word has stack effect ( word -- )."\r
] [\r
- "Branches"\r
+ "* Branches"\r
+ "--"\r
"Now suppose we want to write a word that computes the"\r
"absolute value of a number; that is, if it is less than 0,"\r
"the number will be negated to yield a positive result."\r
"- The f object is false."\r
"- Anything else is true."\r
] [\r
- "More branches"\r
+ "* More branches"\r
+ "--"\r
"On the previous slide, you saw the 'when' conditional:"\r
""\r
[ " ... condition ... [ ... true case ... ] when" ]\r
""\r
[ " ... condition ... [ ... ] [ ... ] ifte" ]\r
] [\r
- "Combinators"\r
+ "* Combinators"\r
+ "--"\r
"ifte, when, unless are words that take lists of code as input."\r
""\r
"Lists of code are called ``quotations''."\r
""\r
[ "10 [ \"Hello combinators\" print ] times" ]\r
] [\r
- "Sequences"\r
+ "* Sequences"\r
+ "--"\r
"You have already seen strings, very briefly:"\r
""\r
" \"Hello world\""\r
"can contain any type of object, including other lists"\r
"and vectors."\r
] [\r
- "Sequences and combinators"\r
+ "* Sequences and combinators"\r
+ "--"\r
"A very useful combinator is each ( seq quot -- )."\r
"It calls a quotation with each element of the sequence in turn."\r
""\r
[ "{ 10 20 30 } [ 3 + ] map ." ]\r
"==> { 13 23 33 }"\r
] [\r
- "Numbers - integers and ratios"\r
+ "* Numbers - integers and ratios"\r
+ "--"\r
"Factor's supports arbitrary-precision integers and ratios."\r
""\r
"Try the following:"\r
"Rational numbers are added, multiplied and reduced to"\r
"lowest terms in the same way you learned in grade school."\r
] [\r
- "Numbers - higher math"\r
- ""\r
+ "* Numbers - higher math"\r
+ "--"\r
[ "2 sqrt ." ]\r
""\r
[ "-1 sqrt ." ]\r
""\r
"... and there is much more for the math geeks."\r
] [\r
- "Object oriented programming"\r
+ "* Object oriented programming"\r
+ "--"\r
"Each object belongs to a class."\r
"Generic words act differently based on an object's class."\r
""\r
""\r
"integer, string, object are built-in classes."\r
] [\r
- "Defining new classes"\r
+ "* Defining new classes"\r
+ "--"\r
"New classes can be defined:"\r
""\r
[ "TUPLE: point x y ;" ]\r
"Tuples support custom constructors, delegation..."\r
"see the developer's handbook for details."\r
] [\r
- "The library"\r
+ "* The library"\r
+ "--"\r
"Offers a good selection of highly-reusable words:"\r
"- Operations on sequences"\r
"- Variety of mathematical functions"\r
"- To show a word definition:"\r
[ "\\ reverse see" ]\r
] [\r
- "Learning more"\r
+ "* Learning more"\r
+ "--"\r
"Hopefully this tutorial has sparked your interest in Factor."\r
""\r
"You can learn more by reading the Factor developer's handbook:"\r
<tutorial> gadget. ;\r
\r
: <tutorial-button>\r
- "Tutorial" [ drop [ tutorial ] pane get pane-call ] <button> ;\r
-\r
+ "Tutorial" <label>\r
+ [ drop [ tutorial ] pane get pane-call ] <button> ;\r
C: book ( pages -- book )
<gadget> over set-delegate
0 over set-book-page
- swap [ over add-gadget ] each ;
+ [ add-gadgets ] keep ;
M: book pref-dim ( book -- dim )
- gadget-children { 0 0 0 } [ pref-dim vmax ] reduce ;
+ gadget-children [ pref-dim ] map { 0 0 0 } [ vmax ] reduce ;
M: book layout* ( book -- )
dup rect-dim over gadget-children [
[ gadget-children length rem ] keep
[ set-book-page ] keep relayout ;
-: first-page ( book -- )
- 0 swap show-page ;
+: first-page ( book -- ) 0 swap show-page ;
-: prev-page ( book -- )
- [ book-page 1 - ] keep show-page ;
+: prev-page ( book -- ) [ book-page 1 - ] keep show-page ;
-: next-page ( book -- )
- [ book-page 1 + ] keep show-page ;
+: next-page ( book -- ) [ book-page 1 + ] keep show-page ;
-: last-page ( book -- )
- -1 swap show-page ;
+: last-page ( book -- ) -1 swap show-page ;
-: book-buttons ( book -- gadget )
- <line-shelf> swap [
- [ "|<" first-page drop ]
- [ "<" prev-page drop ]
- [ ">" next-page drop ]
- [ ">|" last-page drop ]
- ] [
- uncons swapd cons <button> over add-gadget
- ] each-with ;
+TUPLE: book-browser book ;
-: <book-browser> ( book -- gadget )
- dup book-buttons <frame>
- [ add-top ] keep [ add-center ] keep ;
+: find-book ( gadget -- )
+ [ book-browser? ] find-parent book-browser-book ;
+
+: <book-buttons> ( book -- gadget )
+ [
+ { "|<" [ find-book first-page ] }
+ { "<" [ find-book prev-page ] }
+ { ">" [ find-book next-page ] }
+ { ">|" [ find-book last-page ] }
+ ] [ 2unseq >r <label> r> <button> ] map
+ 0 <shelf> [ add-gadgets ] keep ;
+
+C: book-browser ( book -- gadget )
+ <frame> over set-delegate
+ <book-buttons> over add-top
+ [ 2dup set-book-browser-book add-center ] keep ;
C: border ( child delegate size -- border )
[ set-border-size ] keep
[ set-delegate ] keep
- [ over [ add-gadget ] [ 2drop ] ifte ] keep ;
+ [ add-gadget ] keep ;
: empty-border ( child -- border )
<gadget> { 5 5 0 } <border> ;
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> ( gadget quot -- button )
+ >r bevel-border dup button-theme dup r> button-gestures ;
-: <button> ( label quot -- button )
- (button) dup button-theme ;
-
-: <roll-button> ( label quot -- button )
- (button) dup roll-button-theme ;
+: <roll-button> ( gadget quot -- button )
+ >r dup roll-button-theme dup r> button-gestures ;
C: editor ( text -- )
<gadget> over set-delegate
- [ <line-editor> swap set-editor-line ] keep
- [ <caret> swap set-editor-caret ] keep
+ <line-editor> over set-editor-line
+ <caret> over set-editor-caret
[ set-editor-text ] keep
dup editor-actions ;
#! gesture, otherwise returns f.
[ dupd handle-gesture* ] each-parent nip ;
-: link-action ( gadget to from -- )
- #! When gadget receives 'from' gesture, send a 'to' gesture.
- >r [ swap handle-gesture drop ] cons r> set-action ;
-
: user-input ( ch gadget -- ? )
[ dupd user-input* ] each-parent nip ;
sequences vectors ;
: remove-gadget ( gadget parent -- )
- [ 2dup gadget-children remove swap set-gadget-children ] keep
+ 2dup gadget-children remove over set-gadget-children
relayout f swap set-gadget-parent ;
: unparent ( gadget -- )
#! Add a gadget to a parent gadget.
[ (add-gadget) ] keep relayout ;
+: add-gadgets ( seq parent -- )
+ #! Add all gadgets in a sequence to a parent gadget.
+ swap [ over (add-gadget) ] each relayout ;
+
: (parents-down) ( list gadget -- list )
[ [ swons ] keep gadget-parent (parents-down) ] when* ;
dup label-text label-size ;
M: label draw-gadget* ( label -- )
- dup delegate draw-gadget*
- dup label-text draw-string ;
+ dup delegate draw-gadget* dup label-text draw-string ;
: packed-layout ( gadget sizes -- )
2dup packed-locs packed-dims ;
-C: pack ( align fill vector -- pack )
- #! align: 0 left aligns, 1/2 center, 1 right.
+C: pack ( fill vector -- pack )
#! gap: between each child.
#! fill: 0 leaves default width, 1 fills to pack width.
[ <gadget> swap set-delegate ] keep
[ set-pack-vector ] keep
[ set-pack-fill ] keep
- [ set-pack-align ] keep ;
+ 0 over set-pack-align ;
-: <pile> { 0 1 0 } <pack> ;
+: <pile>
( fill -- pack ) { 0 1 0 } <pack> ;
-: <line-pile> 0 0 <pile> ;
-
-: <shelf> { 1 0 0 } <pack> ;
-
-: <line-shelf> 0 0 <shelf> ;
+: <shelf> ( fill -- pack ) { 1 0 0 } <pack> ;
M: pack pref-dim ( pack -- dim )
[
C: stack ( -- gadget )
#! A stack lays out all its children on top of each other.
-
0 1 { 0 0 1 } <pack> over set-delegate ;
+ 1 { 0 0 1 } <pack> over set-delegate ;
M: stack children-on ( point stack -- gadget )
nip gadget-children ;
C: display ( -- display )
<frame> over set-delegate
"" <display-title> over add-display-title
- <line-pile> 2dup swap set-display-pane
+ 0 <pile> 2dup swap set-display-pane
<scroller> over add-center ;
+: make-presentations ( seq -- seq )
+ [
+ dup presented swons unit swap unparse-short
+ <presentation>
+ ] map ;
+
: present-stack ( seq title display -- )
[ display-title set-label-text ] keep
[
- display-pane
- dup clear-gadget swap reverse-slice [
- dup presented swons unit swap unparse-short
- <presentation> swap add-gadget
- ] each-with
+ display-pane dup clear-gadget
+ >r reverse-slice make-presentations r> add-gadgets
] keep relayout ;
: ui-listener-hook ( -- )
1/2 <x-splitter> ;
: listener-application ( -- )
- <pane> dup pane set <scroller>
- <stack-display>
+ <pane> dup pane set <scroller> <stack-display>
2/3 <x-splitter> add-layer
[ clear listener-thread ] in-thread
pane get request-focus ;
: show-menu ( menu -- )
hand screen-loc over set-rect-loc show-glass ;
-: menu-item-border ( child -- border )
- <plain-gadget> { 1 1 0 } <border> ;
-
-: <menu-item> ( label quot -- gadget )
- >r <label> menu-item-border dup roll-button-theme dup
- r> button-gestures ;
-
-TUPLE: menu ;
-
-: menu-actions ( menu -- )
- [ drop hide-glass ] [ button-down 1 ] set-action ;
-
-: assoc>menu ( assoc menu -- )
+: menu-items ( assoc -- pile )
#! Given an association list mapping labels to quotations.
#! Prepend a call to hide-menu to each quotation.
- [
- uncons \ hide-glass swons <menu-item> swap add-gadget
- ] each-with ;
+ [ uncons \ hide-glass swons >r <label> r> <roll-button> ] map
+ 1 <pile> [ add-gadgets ] keep ;
: menu-theme ( menu -- )
<< gradient f { 1 0 0 } { 240 240 255 } { 216 216 216 } >>
interior set-paint-prop ;
-C: menu ( assoc -- gadget )
+: <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
- dup menu-theme ;
+ menu-items line-border dup menu-theme ;
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic hashtables io kernel line-editor listener lists
-math namespaces prettyprint sequences strings styles threads ;
+math namespaces prettyprint sequences strings styles threads
+vectors ;
DEFER: <presentation>
: add-input 2dup set-pane-input add-gadget ;
: <active-line> ( input current -- line )
- <line-shelf> [ add-gadget ] keep [ add-gadget ] keep ;
+ 2vector 0 <shelf> [ add-gadgets ] keep ;
: init-active-line ( pane -- )
dup pane-active unparent
- [ dup pane-
input swap pane-current <active-line> ] keep
+ [ dup pane-
current swap pane-input <active-line> ] keep
2dup set-pane-active add-gadget ;
: pop-continuation ( pane -- quot )
] swap add-actions ;
C: pane ( -- pane )
- <line-pile> over set-delegate
- <line-pile> <incremental> over add-output
- <line-shelf> over set-pane-current
+ 0 <pile> over set-delegate
+ 0 <pile> <incremental> over add-output
+ 0 <shelf> over set-pane-current
"" <editor> over set-pane-input
dup init-active-line
dup pane-actions ;
: pane-terpri ( pane -- )
dup pane-current over pane-print-1
- <line-shelf> over set-pane-current init-active-line ;
+ 0 <shelf> over set-pane-current init-active-line ;
: pane-write ( style pane list -- )
3dup car swap pane-write-1 cdr dup
[ [ third command-quot ] keep second swons ] map-with
<menu> ;
-: init-commands ( gadget -- )
- dup roll-button-theme
- dup presented paint-prop dup [
+: init-commands ( gadget -- gadget )
+ dup presented paint-prop [
[
\ drop ,
literalize ,
[ command-menu show-menu ] %
] [ ] make
- button-gestures
- ] [
- 2drop
- ] ifte ;
+ <roll-button>
+ ] when* ;
: <styled-label> ( style text -- label )
<label> swap dup [ alist>hash ] when over set-gadget-paint ;
: <presentation> ( style text -- presentation )
gadget pick assoc dup
- [ 2nip ] [ drop <styled-label> dup init-commands ] ifte ;
+ [ 2nip ] [ drop <styled-label> init-commands ] ifte ;
: gadget. ( gadget -- )
gadget swons unit
: update-slider ( slider scroller -- )
dup rect-dim pick slider-vector v. pick set-slider-page
dup viewport-dim over rect-dim vmax pick slider-vector v. pick set-slider-max
- slider-viewport dup viewport-origin over fix-scroll vneg pick slider-vector v. pick set-slider-value
- drop slider-elevator relayout ;
+ scroller-viewport dup viewport-origin over fix-scroll vneg pick slider-vector v. pick set-slider-value
+ 2drop ;
: update-sliders ( scroller -- )
- dup scroller-x over update-slider
+ dup
+ dup scroller-x swap update-slider
dup scroller-y swap update-slider ;
: scroll ( origin scroller -- )
- [
- scroller-viewport [ fix-scroll ] keep
- [ set-viewport-origin ] keep
- ] keep relayout ;
+ scroller-viewport
+ [ [ fix-scroll ] keep set-viewport-origin ] keep relayout ;
: add-viewport 2dup set-scroller-viewport add-center ;
M: scroller focusable-child* ( viewport -- gadget )
scroller-viewport ;
-
-M: scroller layout* ( scroller -- )
- dup update-sliders delegate layout* ;
hand hand-click-rel elevator-click ;
: thumb-actions ( thumb -- )
- dup [ drop ] button-gestures
[ find-elevator elevator-motion ] [ drag 1 ] set-action ;
: <thumb> ( -- thumb )
- <bevel-gadget>
+ <gadget> [ drop ] <button>
t over set-gadget-root?
- dup button-theme
dup thumb-actions ;
: elevator-theme ( elevator -- )
M: elevator pref-dim drop thumb-min ;
-: <empty-button> ( quot -- )
- >r <bevel-gadget> { 12 12 0 } over set-gadget-dim
- dup button-theme dup r> button-gestures ;
-
-: <up-button> [ drop ] <empty-button> ;
+: <up-button> <gadget> [ drop ] <button> ;
: add-up { 1 1 1 } over slider-vector v- 2unseq set-frame-child ;
-: <down-button> [ drop ] <empty-button> ;
+: <down-button> <gadget> [ drop ] <button> ;
: add-down { 1 1 1 } over slider-vector v+ 2unseq set-frame-child ;
<elevator> over add-elevator
<up-button> over add-up
<down-button> over add-down
- <thumb> over add-thumb
- dup slider-actions ;
+ <thumb> over add-thumb ;
: <x-slider> ( -- slider ) { 1 0 0 } <slider> ;
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic kernel lists math matrices namespaces sequences
-styles ;
+styles vectors ;
TUPLE: divider splitter ;
dup divider-actions ;
C: splitter ( first second split vector -- splitter )
- [ >r
0 1 rot <pack> r> set-delegate ] keep
+ [ >r
1 swap <pack> r> set-delegate ] keep
[ set-splitter-split ] keep
- swapd
- [ add-gadget ] keep
- <divider> over add-gadget
- [ add-gadget ] keep ;
+ [ >r >r <divider> r> 3vector r> add-gadgets ] keep ;
: <x-splitter> ( first second split -- splitter )
{ 0 1 0 } <splitter> ;
projects / factor.git / commitdiff