steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-09-28 01:11:41 -05:00
parent 4547b713cf d312c97171
commit bb01491d60
61 changed files with 555 additions and 467 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
basis/farkup/farkup-tests.factor
View File

@ -150,3 +150,6 @@ link-no-follow? off
[ "<p>paragraph\n a ___ b</p>" ] [ "<p>paragraph\n a ___ b</p>" ]
[ "paragraph\n a ___ b" convert-farkup ] unit-test [ "paragraph\n a ___ b" convert-farkup ] unit-test
[ "<p>\n<ul><li> a</li>\n</ul><hr/></p>" ]
[ "\n- a\n___" convert-farkup ] unit-test

2
basis/http/server/static/static-docs.factor
View File

@ -32,6 +32,6 @@ $nl
$nl $nl
"It is also possible to override the hook used when serving static files to the client:" "It is also possible to override the hook used when serving static files to the client:"
{ $subsection <file-responder> } { $subsection <file-responder> }
"The default just sends the file's contents with the request; " { $vocab-link "xmode.responder" } " provides an alternate hook which sends a syntax-highlighted version of the file." ; "The default just sends the file's contents with the request; " { $vocab-link "xmode.code2html.responder" } " provides an alternate hook which sends a syntax-highlighted version of the file." ;
ABOUT: "http.server.static" ABOUT: "http.server.static"

2
basis/io/encodings/iana/iana.factor
View File

@ -59,4 +59,4 @@ PRIVATE>
PRIVATE> PRIVATE>
"resource:basis/io/encodings/iana/character-sets" "resource:basis/io/encodings/iana/character-sets"
ascii <file-reader> make-n>e \ n>e-table set-value ascii <file-reader> make-n>e to: n>e-table

4
basis/models/range/range-tests.factor
View File

@ -31,6 +31,6 @@ tools.test models.range ;
! should be able to move by a page of 10 ! should be able to move by a page of 10
[ 10 ] [ [ 10 ] [
setup-range 10 over set-range-page-value setup-range 10 over set-range-page-value
1 over move-by-page range-value 1 over move-by-page range-value
] unit-test ] unit-test

6
basis/prettyprint/prettyprint.factor
View File

@ -123,7 +123,11 @@ PRIVATE>
: callstack. ( callstack -- ) : callstack. ( callstack -- )
callstack>array 2 <groups> [ callstack>array 2 <groups> [
remove-breakpoints remove-breakpoints
3 nesting-limit [ . ] with-variable [
3 nesting-limit set
100 length-limit set
.
] with-scope
] assoc-each ; ] assoc-each ;
: .c ( -- ) callstack callstack. ; : .c ( -- ) callstack callstack. ;

32
basis/syndication/readme.txt
View File

@ -1,32 +0,0 @@
This library is a simple RSS2 parser and RSS reader web
application. To run the web application you'll need to make sure you
have the sqlite library working. This can be tested with
"contrib/sqlite" require
"contrib/sqlite" test-module
Remember that to use "sqlite" you need to have done the following
somewhere:
USE: alien
"sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
Replacing "libsqlite3.so" with the path to the sqlite shared library
or DLL. I put this in my ~/.factor-rc.
The RSS reader web application creates a database file called
'rss-reader.db' in the same directory as the Factor executable when
first started. This database contains all the feed information.
To load the web application use:
"contrib/rss" require
Fire up the web server and navigate to the URL:
http://localhost:8888/responder/maintain-feeds
Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
update the sqlite database with the feed contains. Use 'Database' to
view the entries from the database for that feed.

68
basis/syndication/syndication-docs.factor Normal file
View File

@ -0,0 +1,68 @@
USING: help.markup help.syntax io.streams.string strings urls
calendar xml.data xml.writer present ;
IN: syndication
HELP: entry
{ $description "An Atom or RSS feed entry. Has the following slots:"
{ $table
{ "Name" "Class" }
{ "title" { $link string } }
{ "url" { "any class supported by " { $link present } } }
{ "description" { $link string } }
{ "date" { $link timestamp } }
}
} ;
HELP: <entry>
{ $values { "entry" entry } }
{ $description "Creates a new entry." } ;
HELP: feed
{ $description "An Atom or RSS feed. Has the following slots:"
{ $table
{ "Name" "Class" }
{ "title" { $link string } }
{ "url" { "any class supported by " { $link present } } }
{ "entries" { "a sequence of " { $link entry } " instances" } }
}
} ;
HELP: <feed>
{ $values { "feed" feed } }
{ $description "Creates a new feed." } ;
HELP: download-feed
{ $values { "url" url } { "feed" feed } }
{ $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
HELP: string>feed
{ $values { "string" string } { "feed" feed } }
{ $description "Parses a feed in string form." } ;
HELP: xml>feed
{ $values { "xml" xml } { "feed" feed } }
{ $description "Parses a feed in XML form." } ;
HELP: feed>xml
{ $values { "feed" feed } { "xml" xml } }
{ $description "Converts a feed to Atom XML form." }
{ $notes "The result of this word can then be passed to " { $link write-xml } ", or stored in an HTTP response object." } ;
ARTICLE: "syndication" "Atom and RSS feed syndication"
"The " { $vocab-link "syndication" } " vocabulary implements support for reading Atom and RSS feeds, and writing Atom feeds."
$nl
"Data types:"
{ $subsection feed }
{ $subsection <feed> }
{ $subsection entry }
{ $subsection <entry> }
"Reading feeds:"
{ $subsection download-feed }
{ $subsection string>feed }
{ $subsection xml>feed }
"Writing feeds:"
{ $subsection feed>xml }
"The " { $vocab-link "furnace.syndication" } " vocabulary builds on top of this vocabulary to enable easy generation of Atom feeds from web applications. The " { $vocab-link "webapps.planet" } " vocabulary is a complete example of a web application which reads and exports feeds."
{ $see-also "urls" } ;
ABOUT: "syndication"

4
basis/syndication/syndication.factor
View File

@ -102,12 +102,12 @@ TUPLE: entry title url description date ;
{ "feed" [ atom1.0 ] } { "feed" [ atom1.0 ] }
} case ; } case ;
: read-feed ( string -- feed ) : string>feed ( string -- feed )
[ string>xml xml>feed ] with-html-entities ; [ string>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed ) : download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple. #! Retrieve an news syndication file, return as a feed tuple.
http-get nip read-feed ; http-get nip string>feed ;
! Atom generation ! Atom generation
: simple-tag, ( content name -- ) : simple-tag, ( content name -- )

18
basis/tools/deploy/deploy-tests.factor
View File

@ -43,6 +43,11 @@ namespaces continuations layouts accessors ;
[ t ] [ 2500000 small-enough? ] unit-test [ t ] [ 2500000 small-enough? ] unit-test
: run-temp-image ( -- )
vm
"-i=" "test.image" temp-file append
2array try-process ;
{ {
"tools.deploy.test.1" "tools.deploy.test.1"
"tools.deploy.test.2" "tools.deploy.test.2"
@ -51,9 +56,7 @@ namespaces continuations layouts accessors ;
} [ } [
[ ] swap [ [ ] swap [
shake-and-bake shake-and-bake
vm run-temp-image
"-i=" "test.image" temp-file append
2array try-process
] curry unit-test ] curry unit-test
] each ] each
@ -88,9 +91,12 @@ M: quit-responder call-responder*
[ ] [ [ ] [
"tools.deploy.test.5" shake-and-bake "tools.deploy.test.5" shake-and-bake
vm run-temp-image
"-i=" "test.image" temp-file append
2array try-process
] unit-test ] unit-test
[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test [ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
[ ] [
"tools.deploy.test.6" shake-and-bake
run-temp-image
] unit-test

13
basis/tools/deploy/test/6/6.factor Normal file
View File

@ -0,0 +1,13 @@
IN: tools.deploy.test.6
USING: values math kernel ;
VALUE: x
VALUE: y
: deploy-test-6 ( -- )
1 to: x
2 to: y
x y + 3 assert= ;
MAIN: deploy-test-6

15
basis/tools/deploy/test/6/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? f }
{ deploy-ui? f }
{ deploy-io 1 }
{ deploy-c-types? f }
{ deploy-name "tools.deploy.test.6" }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? f }
}

8
basis/ui/gadgets/books/books.factor
View File

@ -16,15 +16,15 @@ M: book model-changed ( model book -- )
relayout ; relayout ;
: new-book ( pages model class -- book ) : new-book ( pages model class -- book )
new-gadget new-gadget
swap >>model swap >>model
swap add-gadgets ; inline swap add-gadgets ; inline
: <book> ( pages model -- book ) book new-book ; : <book> ( pages model -- book ) book new-book ;
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ; M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
M: book layout* ( book -- ) M: book layout* ( book -- )
[ dim>> ] [ children>> ] bi [ (>>dim) ] with each ; [ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
M: book focusable-child* ( book -- child/t ) current-page ; M: book focusable-child* ( book -- child/t ) current-page ;

5
basis/ui/gadgets/borders/borders.factor
View File

@ -10,7 +10,7 @@ TUPLE: border < gadget
{ align initial: { 1/2 1/2 } } ; { align initial: { 1/2 1/2 } } ;
: new-border ( child class -- border ) : new-border ( child class -- border )
new-gadget [ swap add-gadget drop ] keep ; inline new-gadget swap add-gadget ; inline
: <border> ( child gap -- border ) : <border> ( child gap -- border )
swap border new-border swap border new-border
@ -42,7 +42,8 @@ M: border pref-dim*
M: border layout* M: border layout*
dup border-child-rect swap gadget-child dup border-child-rect swap gadget-child
over loc>> >>loc over loc>> >>loc
swap dim>> swap (>>dim) ; swap dim>> >>dim
drop ;
M: border focusable-child* M: border focusable-child*
gadget-child ; gadget-child ;

57
basis/ui/gadgets/buttons/buttons.factor
View File

@ -25,7 +25,7 @@ TUPLE: button < border pressed? selected? quot ;
dup mouse-clicked? dup mouse-clicked?
over button-rollover? and over button-rollover? and
buttons-down? and buttons-down? and
over (>>pressed?) >>pressed?
relayout-1 ; relayout-1 ;
: if-clicked ( button quot -- ) : if-clicked ( button quot -- )
@ -115,20 +115,18 @@ M: checkmark-paint draw-interior
dup { 0 1 } v* swap { 1 0 } v* gl-line dup { 0 1 } v* swap { 1 0 } v* gl-line
] with-translation ; ] with-translation ;
: checkmark-theme ( gadget -- ) : checkmark-theme ( gadget -- gadget )
f f
f f
black <solid> black <solid>
black <checkmark-paint> black <checkmark-paint>
<button-paint> <button-paint> >>interior
over (>>interior) black <solid> >>boundary ;
black <solid>
swap (>>boundary) ;
: <checkmark> ( -- gadget ) : <checkmark> ( -- gadget )
<gadget> <gadget>
dup checkmark-theme checkmark-theme
{ 14 14 } over (>>dim) ; { 14 14 } >>dim ;
: toggle-model ( model -- ) : toggle-model ( model -- )
[ not ] change-model ; [ not ] change-model ;
@ -148,7 +146,7 @@ TUPLE: checkbox < button ;
align-left ; align-left ;
M: checkbox model-changed M: checkbox model-changed
swap value>> over (>>selected?) relayout-1 ; swap value>> >>selected? relayout-1 ;
TUPLE: radio-paint color ; TUPLE: radio-paint color ;
@ -162,20 +160,18 @@ M: radio-paint draw-boundary
color>> set-color color>> set-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ; origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
: radio-knob-theme ( gadget -- ) : radio-knob-theme ( gadget -- gadget )
f f
f f
black <radio-paint> black <radio-paint>
black <radio-paint> black <radio-paint>
<button-paint> <button-paint> >>interior
over (>>interior) black <radio-paint> >>boundary ;
black <radio-paint>
swap (>>boundary) ;
: <radio-knob> ( -- gadget ) : <radio-knob> ( -- gadget )
<gadget> <gadget>
dup radio-knob-theme radio-knob-theme
{ 16 16 } over (>>dim) ; { 16 16 } >>dim ;
TUPLE: radio-control < button value ; TUPLE: radio-control < button value ;
@ -188,13 +184,12 @@ TUPLE: radio-control < button value ;
M: radio-control model-changed M: radio-control model-changed
swap value>> swap value>>
over value>> = over value>> = >>selected?
over (>>selected?)
relayout-1 ; relayout-1 ;
: <radio-controls> ( parent model assoc quot -- parent ) : <radio-controls> ( parent model assoc quot -- parent )
#! quot has stack effect ( value model label -- ) #! quot has stack effect ( value model label -- )
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget ) : radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap { 5 5 } >>gap
@ -204,18 +199,18 @@ M: radio-control model-changed
<radio-knob> label-on-right radio-button-theme <radio-control> ; <radio-knob> label-on-right radio-button-theme <radio-control> ;
: <radio-buttons> ( model assoc -- gadget ) : <radio-buttons> ( model assoc -- gadget )
<filled-pile> <filled-pile>
-rot -rot
[ <radio-button> ] <radio-controls> [ <radio-button> ] <radio-controls>
{ 5 5 } >>gap ; { 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget ) : <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ; <radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget ) : <toggle-buttons> ( model assoc -- gadget )
<shelf> <shelf>
-rot -rot
[ <toggle-button> ] <radio-controls> ; [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot ) : command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ; [ invoke-command drop ] 2curry ;
@ -227,7 +222,7 @@ M: radio-control model-changed
<bevel-button> ; <bevel-button> ;
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
<shelf> <shelf>
swap swap
"toolbar" over class command-map commands>> swap "toolbar" over class command-map commands>> swap
[ -rot <command-button> add-gadget ] curry assoc-each ; [ -rot <command-button> add-gadget ] curry assoc-each ;

4
basis/ui/gadgets/editors/editors.factor
View File

@ -96,9 +96,9 @@ M: editor ungraft*
: click-loc ( editor model -- ) : click-loc ( editor model -- )
>r clicked-loc r> set-model ; >r clicked-loc r> set-model ;
: focus-editor ( editor -- ) t over (>>focused?) relayout-1 ; : focus-editor ( editor -- ) t >>focused? relayout-1 ;
: unfocus-editor ( editor -- ) f over (>>focused?) relayout-1 ; : unfocus-editor ( editor -- ) f >>focused? relayout-1 ;
: (offset>x) ( font col# str -- x ) : (offset>x) ( font col# str -- x )
swap head-slice string-width ; swap head-slice string-width ;

16
basis/ui/gadgets/gadgets-tests.factor
View File

@ -9,9 +9,9 @@ IN: ui.gadgets.tests
! c contains b contains a ! c contains b contains a
<gadget> "a" set <gadget> "a" set
<gadget> "b" set <gadget> "b" set
"a" get "b" get swap add-gadget drop "b" get "a" get add-gadget drop
<gadget> "c" set <gadget> "c" set
"b" get "c" get swap add-gadget drop "c" get "b" get add-gadget drop
! position a and b ! position a and b
"a" get { 100 200 } >>loc drop "a" get { 100 200 } >>loc drop
@ -33,8 +33,8 @@ IN: ui.gadgets.tests
<gadget> "g3" set <gadget> "g3" set
"g3" get { 100 200 } >>dim drop "g3" get { 100 200 } >>dim drop
"g1" get "g2" get swap add-gadget drop "g2" get "g1" get add-gadget drop
"g2" get "g3" get swap add-gadget drop "g3" get "g2" get add-gadget drop
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test [ { 30 30 } ] [ "g1" get screen-loc ] unit-test
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test [ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
@ -49,11 +49,11 @@ IN: ui.gadgets.tests
<gadget> "g1" set <gadget> "g1" set
"g1" get { 300 300 } >>dim drop "g1" get { 300 300 } >>dim drop
<gadget> "g2" set <gadget> "g2" set
"g2" get "g1" get swap add-gadget drop "g1" get "g2" get add-gadget drop
"g2" get { 20 20 } >>loc "g2" get { 20 20 } >>loc
{ 20 20 } >>dim drop { 20 20 } >>dim drop
<gadget> "g3" set <gadget> "g3" set
"g3" get "g1" get swap add-gadget drop "g1" get "g3" get add-gadget drop
"g3" get { 100 100 } >>loc "g3" get { 100 100 } >>loc
{ 20 20 } >>dim drop { 20 20 } >>dim drop
@ -66,7 +66,7 @@ IN: ui.gadgets.tests
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test [ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
<gadget> "g4" set <gadget> "g4" set
"g4" get "g2" get swap add-gadget drop "g2" get "g4" get add-gadget drop
"g4" get { 5 5 } >>loc "g4" get { 5 5 } >>loc
{ 1 1 } >>dim drop { 1 1 } >>dim drop
@ -121,7 +121,7 @@ M: mock-gadget ungraft*
: add-some-children : add-some-children
3 [ 3 [
<mock-gadget> over <model> >>model <mock-gadget> over <model> >>model
dup "g" get swap add-gadget drop "g" get over add-gadget drop
swap 1+ number>string set swap 1+ number>string set
] each ; ] each ;

45
basis/ui/gadgets/gadgets.factor
View File

@ -27,10 +27,10 @@ M: gadget model-changed 2drop ;
: nth-gadget ( n gadget -- child ) children>> nth ; : nth-gadget ( n gadget -- child ) children>> nth ;
: init-gadget ( gadget -- gadget ) : init-gadget ( gadget -- gadget )
init-rect init-rect
{ 0 1 } >>orientation { 0 1 } >>orientation
t >>visible? t >>visible?
{ f f } >>graft-state ; inline { f f } >>graft-state ; inline
: new-gadget ( class -- gadget ) new init-gadget ; inline : new-gadget ( class -- gadget ) new init-gadget ; inline
@ -132,9 +132,9 @@ M: array gadget-text*
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ; : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
: invalidate ( gadget -- ) : invalidate ( gadget -- )
\ invalidate swap (>>layout-state) ; \ invalidate >>layout-state drop ;
: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ; : forget-pref-dim ( gadget -- ) f >>pref-dim drop ;
: layout-queue ( -- queue ) \ layout-queue get ; : layout-queue ( -- queue ) \ layout-queue get ;
@ -147,7 +147,7 @@ M: array gadget-text*
DEFER: relayout DEFER: relayout
: invalidate* ( gadget -- ) : invalidate* ( gadget -- )
\ invalidate* over (>>layout-state) \ invalidate* >>layout-state
dup forget-pref-dim dup forget-pref-dim
dup root?>> dup root?>>
[ layout-later ] [ parent>> [ relayout ] when* ] if ; [ layout-later ] [ parent>> [ relayout ] when* ] if ;
@ -160,20 +160,19 @@ DEFER: relayout
dup layout-state>> dup layout-state>>
[ drop ] [ dup invalidate layout-later ] if ; [ drop ] [ dup invalidate layout-later ] if ;
: show-gadget ( gadget -- ) t swap (>>visible?) ; : show-gadget ( gadget -- ) t >>visible? drop ;
: hide-gadget ( gadget -- ) f swap (>>visible?) ; : hide-gadget ( gadget -- ) f >>visible? drop ;
DEFER: in-layout? DEFER: in-layout?
: do-invalidate ( gadget -- gadget ) GENERIC: dim-changed ( gadget -- )
in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
M: gadget dim-changed
in-layout? get [ invalidate ] [ invalidate* ] if ;
M: gadget (>>dim) ( dim gadget -- ) M: gadget (>>dim) ( dim gadget -- )
2dup dim>> = 2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
[ 2drop ]
[ tuck call-next-method do-invalidate drop ]
if ;
GENERIC: pref-dim* ( gadget -- dim ) GENERIC: pref-dim* ( gadget -- dim )
@ -194,9 +193,9 @@ GENERIC: layout* ( gadget -- )
M: gadget layout* drop ; M: gadget layout* drop ;
: prefer ( gadget -- ) dup pref-dim swap (>>dim) ; : prefer ( gadget -- ) dup pref-dim >>dim drop ;
: validate ( gadget -- ) f swap (>>layout-state) ; : validate ( gadget -- ) f >>layout-state drop ;
: layout ( gadget -- ) : layout ( gadget -- )
dup layout-state>> [ dup layout-state>> [
@ -255,11 +254,10 @@ M: gadget ungraft* drop ;
: (unparent) ( gadget -- ) : (unparent) ( gadget -- )
dup ungraft dup ungraft
dup forget-pref-dim dup forget-pref-dim
f swap (>>parent) ; f >>parent drop ;
: unfocus-gadget ( child gadget -- ) : unfocus-gadget ( child gadget -- )
tuck focus>> eq? tuck focus>> eq? [ f >>focus ] when drop ;
[ f swap (>>focus) ] [ drop ] if ;
SYMBOL: in-layout? SYMBOL: in-layout?
@ -282,8 +280,7 @@ SYMBOL: in-layout?
: (clear-gadget) ( gadget -- ) : (clear-gadget) ( gadget -- )
dup [ (unparent) ] each-child dup [ (unparent) ] each-child
f over (>>focus) f >>focus f >>children drop ;
f swap (>>children) ;
: clear-gadget ( gadget -- ) : clear-gadget ( gadget -- )
not-in-layout not-in-layout
@ -305,7 +302,7 @@ SYMBOL: in-layout?
not-in-layout not-in-layout
(add-gadget) (add-gadget)
dup relayout ; dup relayout ;
: add-gadgets ( parent children -- parent ) : add-gadgets ( parent children -- parent )
not-in-layout not-in-layout
[ (add-gadget) ] each [ (add-gadget) ] each

18
basis/ui/gadgets/grids/grids.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors io.streams.string math.vectors ui.gadgets columns accessors
math.geometry.rect ; math.geometry.rect locals ;
IN: ui.gadgets.grids IN: ui.gadgets.grids
TUPLE: grid < gadget TUPLE: grid < gadget
@ -12,18 +12,18 @@ grid
: new-grid ( children class -- grid ) : new-grid ( children class -- grid )
new-gadget new-gadget
[ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ; swap >>grid
inline dup grid>> concat add-gadgets ; inline
: <grid> ( children -- grid ) : <grid> ( children -- grid )
grid new-grid ; grid new-grid ;
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ; : grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( grid child i j -- grid ) :: grid-add ( grid child i j -- grid )
>r >r dupd swap r> r> grid i j grid-child unparent
>r >r 2dup swap add-gadget drop r> r> grid child add-gadget
3dup grid-child unparent rot grid>> nth set-nth ; child i j grid grid>> nth set-nth ;
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ; : grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
@ -33,10 +33,10 @@ grid
: (compute-grid) ( grid -- seq ) [ max-dim ] map ; : (compute-grid) ( grid -- seq ) [ max-dim ] map ;
: compute-grid ( grid -- horiz vert ) : compute-grid ( grid -- horiz vert )
pref-dim-grid dup flip (compute-grid) swap (compute-grid) ; pref-dim-grid [ flip (compute-grid) ] [ (compute-grid) ] bi ;
: (pair-up) ( horiz vert -- dim ) : (pair-up) ( horiz vert -- dim )
>r first r> second 2array ; [ first ] [ second ] bi* 2array ;
: pair-up ( horiz vert -- dims ) : pair-up ( horiz vert -- dims )
[ [ (pair-up) ] curry map ] with map ; [ [ (pair-up) ] curry map ] with map ;

2
basis/ui/gadgets/incremental/incremental-docs.factor
View File

@ -8,7 +8,7 @@ $nl
$nl $nl
"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words." "Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
$nl $nl
"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $snippet "align" } ", " { $snippet "fill" } ", and " { $snippet "gap" } "." } ; "Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for the " { $slot "align" } ", " { $slot "fill" } ", and " { $slot "gap" } " slots." } ;
HELP: <incremental> HELP: <incremental>
{ $values { "incremental" "a new instance of " { $link incremental } } } { $values { "incremental" "a new instance of " { $link incremental } } }

39
basis/ui/gadgets/incremental/incremental.factor
View File

@ -4,17 +4,6 @@ USING: io kernel math namespaces math.vectors ui.gadgets
ui.gadgets.packs accessors math.geometry.rect ; ui.gadgets.packs accessors math.geometry.rect ;
IN: ui.gadgets.incremental IN: ui.gadgets.incremental
! Incremental layout allows adding lines to panes to be O(1).
! Note that incremental packs are distinct from ordinary packs
! defined in layouts.factor, since you don't want all packs to
! be incremental. In particular, incremental packs do not
! support non-default values for pack-align, pack-fill and
! pack-gap.
! The cursor is the current size of the incremental pack.
! New gadgets are added at
! incremental-cursor gadget-orientation v*
TUPLE: incremental < pack cursor ; TUPLE: incremental < pack cursor ;
: <incremental> ( -- incremental ) : <incremental> ( -- incremental )
@ -24,38 +13,42 @@ TUPLE: incremental < pack cursor ;
M: incremental pref-dim* M: incremental pref-dim*
dup layout-state>> [ dup layout-state>> [
dup call-next-method over (>>cursor) dup call-next-method >>cursor
] when cursor>> ; ] when cursor>> ;
: next-cursor ( gadget incremental -- cursor ) : next-cursor ( gadget incremental -- cursor )
[ [
swap rect-dim swap cursor>> [ rect-dim ] [ cursor>> ] bi*
2dup v+ >r vmax r> [ vmax ] [ v+ ] 2bi
] keep orientation>> set-axis ; ] keep orientation>> set-axis ;
: update-cursor ( gadget incremental -- ) : update-cursor ( gadget incremental -- )
[ next-cursor ] keep (>>cursor) ; tuck next-cursor >>cursor drop ;
: incremental-loc ( gadget incremental -- ) : incremental-loc ( gadget incremental -- )
[ cursor>> ] [ orientation>> ] bi v* [ cursor>> ] [ orientation>> ] bi v*
>>loc drop ; >>loc drop ;
: prefer-incremental ( gadget -- ) : prefer-incremental ( gadget -- ) USE: slots.private
dup forget-pref-dim dup pref-dim >>dim drop ; dup forget-pref-dim dup pref-dim >>dim drop ;
M: incremental dim-changed drop ;
: add-incremental ( gadget incremental -- ) : add-incremental ( gadget incremental -- )
not-in-layout not-in-layout
2dup swap (add-gadget) drop 2dup swap (add-gadget) drop
over prefer-incremental t in-layout? [
over layout-later over prefer-incremental
2dup incremental-loc over layout-later
tuck update-cursor 2dup incremental-loc
dup prefer-incremental tuck update-cursor
parent>> [ invalidate* ] when* ; dup prefer-incremental
parent>> [ invalidate* ] when*
] with-variable ;
: clear-incremental ( incremental -- ) : clear-incremental ( incremental -- )
not-in-layout not-in-layout
dup (clear-gadget) dup (clear-gadget)
dup forget-pref-dim dup forget-pref-dim
{ 0 0 } over (>>cursor) { 0 0 } >>cursor
parent>> [ relayout ] when* ; parent>> [ relayout ] when* ;

32
basis/ui/gadgets/labelled/labelled.factor
View File

@ -11,10 +11,10 @@ IN: ui.gadgets.labelled
TUPLE: labelled-gadget < track content ; TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <labelled-gadget> ( gadget title -- newgadget )
{ 0 1 } labelled-gadget new-track { 0 1 } labelled-gadget new-track
swap <label> reverse-video-theme f track-add swap <label> reverse-video-theme f track-add
swap >>content swap >>content
dup content>> 1 track-add ; dup content>> 1 track-add ;
M: labelled-gadget focusable-child* content>> ; M: labelled-gadget focusable-child* content>> ;
@ -22,25 +22,25 @@ M: labelled-gadget focusable-child* content>> ;
>r <scroller> r> <labelled-gadget> ; >r <scroller> r> <labelled-gadget> ;
: <labelled-pane> ( model quot scrolls? title -- gadget ) : <labelled-pane> ( model quot scrolls? title -- gadget )
>r >r <pane-control> r> over (>>scrolls?) r> >r >r <pane-control> r> >>scrolls? r>
<labelled-scroller> ; <labelled-scroller> ;
: <close-box> ( quot -- button/f ) : <close-box> ( quot -- button/f )
gray close-box <polygon-gadget> swap <bevel-button> ; gray close-box <polygon-gadget> swap <bevel-button> ;
: title-theme ( gadget -- ) : title-theme ( gadget -- gadget )
{ 1 0 } over (>>orientation) { 1 0 } >>orientation
T{ gradient f { T{ gradient f {
T{ rgba f 0.65 0.65 1.0 1.0 } T{ rgba f 0.65 0.65 1.0 1.0 }
T{ rgba f 0.65 0.45 1.0 1.0 } T{ rgba f 0.65 0.45 1.0 1.0 }
} } swap (>>interior) ; } } >>interior ;
: <title-label> ( text -- label ) <label> dup title-theme ; : <title-label> ( text -- label ) <label> title-theme ;
: <title-bar> ( title quot -- gadget ) : <title-bar> ( title quot -- gadget )
<frame> <frame>
swap dup [ <close-box> @left grid-add ] [ drop ] if swap dup [ <close-box> @left grid-add ] [ drop ] if
swap <title-label> @center grid-add ; swap <title-label> @center grid-add ;
TUPLE: closable-gadget < frame content ; TUPLE: closable-gadget < frame content ;
@ -48,9 +48,9 @@ TUPLE: closable-gadget < frame content ;
[ closable-gadget? ] find-parent ; [ closable-gadget? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget ) : <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new-frame closable-gadget new-frame
-rot <title-bar> @top grid-add -rot <title-bar> @top grid-add
swap >>content swap >>content
dup content>> @center grid-add ; dup content>> @center grid-add ;
M: closable-gadget focusable-child* content>> ; M: closable-gadget focusable-child* content>> ;

14
basis/ui/gadgets/labels/labels.factor
View File

@ -63,11 +63,11 @@ M: object >label ;
M: f >label drop <gadget> ; M: f >label drop <gadget> ;
: label-on-left ( gadget label -- button ) : label-on-left ( gadget label -- button )
{ 1 0 } <track> { 1 0 } <track>
swap >label f track-add swap >label f track-add
swap 1 track-add ; swap 1 track-add ;
: label-on-right ( label gadget -- button ) : label-on-right ( label gadget -- button )
{ 1 0 } <track> { 1 0 } <track>
swap f track-add swap f track-add
swap >label 1 track-add ; swap >label 1 track-add ;

9
basis/ui/gadgets/lists/lists.factor
View File

@ -27,8 +27,7 @@ TUPLE: list < pack index presenter color hook ;
control-value length 1- min 0 max ; control-value length 1- min 0 max ;
: bound-index ( list -- ) : bound-index ( list -- )
dup index>> over calc-bounded-index dup index>> over calc-bounded-index >>index drop ;
swap (>>index) ;
: list-presentation-hook ( list -- quot ) : list-presentation-hook ( list -- quot )
hook>> [ [ list? ] find-parent ] prepend ; hook>> [ [ list? ] find-parent ] prepend ;
@ -49,7 +48,7 @@ TUPLE: list < pack index presenter color hook ;
M: list model-changed M: list model-changed
nip nip
dup clear-gadget dup clear-gadget
dup <list-items> over swap add-gadgets drop dup <list-items> add-gadgets
bound-index ; bound-index ;
: selected-rect ( list -- rect ) : selected-rect ( list -- rect )
@ -79,8 +78,8 @@ M: list focusable-child* drop t ;
2drop 2drop
] [ ] [
[ control-value length rem ] keep [ control-value length rem ] keep
[ (>>index) ] keep swap >>index
[ relayout-1 ] keep dup relayout-1
scroll>selected scroll>selected
] if ; ] if ;

20
basis/ui/gadgets/menus/menus.factor
View File

@ -15,19 +15,17 @@ TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass ) : <menu-glass> ( menu world -- glass )
menu-glass new-gadget menu-glass new-gadget
>r over menu-loc >>loc r> >r over menu-loc >>loc r>
[ swap add-gadget drop ] keep ; swap add-gadget ;
M: menu-glass layout* gadget-child prefer ; M: menu-glass layout* gadget-child prefer ;
: hide-glass ( world -- ) : hide-glass ( world -- )
dup glass>> [ unparent ] when* [ [ unparent ] when* f ] change-glass drop ;
f swap (>>glass) ;
: show-glass ( gadget world -- ) : show-glass ( gadget world -- )
over hand-clicked set-global dup hide-glass
[ hide-glass ] keep swap [ hand-clicked set-global ] [ >>glass ] bi
[ swap add-gadget drop ] 2keep dup glass>> add-gadget drop ;
(>>glass) ;
: show-menu ( gadget owner -- ) : show-menu ( gadget owner -- )
find-world [ <menu-glass> ] keep show-glass ; find-world [ <menu-glass> ] keep show-glass ;
@ -48,7 +46,7 @@ M: menu-glass layout* gadget-child prefer ;
faint-boundary ; faint-boundary ;
: <commands-menu> ( hook target commands -- gadget ) : <commands-menu> ( hook target commands -- gadget )
<filled-pile> <filled-pile>
-roll -roll
[ <menu-item> add-gadget ] with with each [ <menu-item> add-gadget ] with with each
5 <border> menu-theme ; 5 <border> menu-theme ;

8
basis/ui/gadgets/packs/packs.factor
View File

@ -5,9 +5,9 @@ math.vectors namespaces math.order accessors math.geometry.rect ;
IN: ui.gadgets.packs IN: ui.gadgets.packs
TUPLE: pack < gadget TUPLE: pack < gadget
{ align initial: 0 } { align initial: 0 }
{ fill initial: 0 } { fill initial: 0 }
{ gap initial: { 0 0 } } ; { gap initial: { 0 0 } } ;
: packed-dim-2 ( gadget sizes -- list ) : packed-dim-2 ( gadget sizes -- list )
[ over rect-dim over v- rot fill>> v*n v+ ] with map ; [ over rect-dim over v- rot fill>> v*n v+ ] with map ;
@ -40,7 +40,7 @@ TUPLE: pack < gadget
: <pile> ( -- pack ) { 0 1 } <pack> ; : <pile> ( -- pack ) { 0 1 } <pack> ;
: <filled-pile> ( -- pack ) <pile> 1 over (>>fill) ; : <filled-pile> ( -- pack ) <pile> 1 >>fill ;
: <shelf> ( -- pack ) { 1 0 } <pack> ; : <shelf> ( -- pack ) { 1 0 } <pack> ;

90
basis/ui/gadgets/panes/panes.factor
View File

@ -1,45 +1,51 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render ui.clipboards ui.gestures ui.traverse ui.render hashtables io
hashtables io kernel namespaces sequences io.styles strings kernel namespaces sequences io.styles strings quotations math
quotations math opengl combinators math.vectors opengl combinators math.vectors sorting splitting
sorting splitting io.streams.nested assocs io.streams.nested assocs ui.gadgets.presentations
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
ui.gadgets.grid-lines classes.tuple models continuations classes.tuple models continuations destructors accessors
destructors accessors math.geometry.rect ; math.geometry.rect ;
IN: ui.gadgets.panes IN: ui.gadgets.panes
TUPLE: pane < pack TUPLE: pane < pack
output current prototype scrolls? output current prototype scrolls?
selection-color caret mark selecting? ; selection-color caret mark selecting? ;
: clear-selection ( pane -- pane ) f >>caret f >>mark ; : clear-selection ( pane -- pane )
f >>caret f >>mark ;
: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ; : add-output ( pane current -- pane )
: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ; [ >>output ] [ add-gadget ] bi ;
: add-current ( pane current -- pane )
[ >>current ] [ add-gadget ] bi ;
: prepare-line ( pane -- pane ) : prepare-line ( pane -- pane )
clear-selection clear-selection
dup prototype>> clone add-current ; dup prototype>> clone add-current ;
: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ; : pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq ) : selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ; [ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ; M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ; M: pane gadget-selection ( pane -- string/f )
selected-children gadget-text ;
: pane-clear ( pane -- ) : pane-clear ( pane -- )
clear-selection clear-selection
[ output>> clear-incremental ] [ output>> clear-incremental ]
[ current>> clear-gadget ] [ current>> clear-gadget ]
bi ; bi ;
: new-pane ( class -- pane ) : new-pane ( class -- pane )
new-gadget new-gadget
@ -109,7 +115,7 @@ C: <pane-stream> pane-stream
GENERIC: write-gadget ( gadget stream -- ) GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget ( gadget pane-stream -- ) M: pane-stream write-gadget ( gadget pane-stream -- )
pane>> current>> swap add-gadget drop ; pane>> current>> swap add-gadget drop ;
M: style-stream write-gadget M: style-stream write-gadget
stream>> write-gadget ; stream>> write-gadget ;
@ -132,12 +138,12 @@ M: style-stream write-gadget
: make-pane ( quot -- gadget ) : make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline <pane> [ swap with-pane ] keep smash-pane ; inline
: <scrolling-pane> ( -- pane ) <pane> t over (>>scrolls?) ; : <scrolling-pane> ( -- pane ) <pane> t >>scrolls? ;
TUPLE: pane-control < pane quot ; TUPLE: pane-control < pane quot ;
M: pane-control model-changed ( model pane-control -- ) M: pane-control model-changed ( model pane-control -- )
[ value>> ] [ dup quot>> ] bi* with-pane ; [ value>> ] [ dup quot>> ] bi* with-pane ;
: <pane-control> ( model quot -- pane ) : <pane-control> ( model quot -- pane )
pane-control new-pane pane-control new-pane
@ -172,7 +178,7 @@ M: pane-stream make-span-stream
>r pick at r> when* ; inline >r pick at r> when* ; inline
: apply-foreground-style ( style gadget -- style gadget ) : apply-foreground-style ( style gadget -- style gadget )
foreground [ over (>>color) ] apply-style ; foreground [ >>color ] apply-style ;
: apply-background-style ( style gadget -- style gadget ) : apply-background-style ( style gadget -- style gadget )
background [ solid-interior ] apply-style ; background [ solid-interior ] apply-style ;
@ -183,7 +189,7 @@ M: pane-stream make-span-stream
font-size swap at 12 or 3array ; font-size swap at 12 or 3array ;
: apply-font-style ( style gadget -- style gadget ) : apply-font-style ( style gadget -- style gadget )
over specified-font over (>>font) ; over specified-font >>font ;
: apply-presentation-style ( style gadget -- style gadget ) : apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ; presented [ <presentation> ] apply-style ;
@ -254,15 +260,15 @@ M: pane-stream make-block-stream
! Tables ! Tables
: apply-table-gap-style ( style grid -- style grid ) : apply-table-gap-style ( style grid -- style grid )
table-gap [ over (>>gap) ] apply-style ; table-gap [ >>gap ] apply-style ;
: apply-table-border-style ( style grid -- style grid ) : apply-table-border-style ( style grid -- style grid )
table-border [ <grid-lines> over (>>boundary) ] table-border [ <grid-lines> >>boundary ]
apply-style ; apply-style ;
: styled-grid ( style grid -- grid ) : styled-grid ( style grid -- grid )
<grid> <grid>
f over (>>fill?) f >>fill?
apply-table-gap-style apply-table-gap-style
apply-table-border-style apply-table-border-style
nip ; nip ;
@ -286,13 +292,13 @@ M: pack dispose drop ;
M: paragraph dispose drop ; M: paragraph dispose drop ;
: gadget-write ( string gadget -- ) : gadget-write ( string gadget -- )
over empty? swap dup empty?
[ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ; [ 2drop ] [ <label> text-theme add-gadget drop ] if ;
M: pack stream-write gadget-write ; M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- ) : gadget-bl ( style stream -- )
>r " " <word-break-gadget> style-label r> swap add-gadget drop ; swap " " <word-break-gadget> style-label add-gadget drop ;
M: paragraph stream-write M: paragraph stream-write
swap " " split swap " " split
@ -309,8 +315,8 @@ M: paragraph stream-write1
[ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ; [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
: gadget-format ( string style stream -- ) : gadget-format ( string style stream -- )
pick empty? spin dup empty?
[ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ; [ 3drop ] [ <styled-label> add-gadget drop ] if ;
M: pack stream-format M: pack stream-format
gadget-format ; gadget-format ;
@ -326,13 +332,13 @@ M: paragraph stream-format
] if ; ] if ;
: caret>mark ( pane -- pane ) : caret>mark ( pane -- pane )
dup caret>> >>mark dup caret>> >>mark
dup relayout-1 ; dup relayout-1 ;
GENERIC: sloppy-pick-up* ( loc gadget -- n ) GENERIC: sloppy-pick-up* ( loc gadget -- n )
M: pack sloppy-pick-up* ( loc gadget -- n ) M: pack sloppy-pick-up* ( loc gadget -- n )
[ orientation>> ] [ children>> ] bi (fast-children-on) ; [ orientation>> ] [ children>> ] bi (fast-children-on) ;
M: gadget sloppy-pick-up* M: gadget sloppy-pick-up*
children>> [ inside? ] with find-last drop ; children>> [ inside? ] with find-last drop ;
@ -350,12 +356,10 @@ M: f sloppy-pick-up*
if ; if ;
: move-caret ( pane -- pane ) : move-caret ( pane -- pane )
dup hand-rel dup hand-rel over sloppy-pick-up >>caret
over sloppy-pick-up dup relayout-1 ;
over (>>caret)
dup relayout-1 ;
: begin-selection ( pane -- ) move-caret f swap (>>mark) ; : begin-selection ( pane -- ) move-caret f >>mark drop ;
: extend-selection ( pane -- ) : extend-selection ( pane -- )
hand-moved? [ hand-moved? [

4
basis/ui/gadgets/paragraphs/paragraphs.factor
View File

@ -17,8 +17,8 @@ TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget ) : <paragraph> ( margin -- gadget )
paragraph new-gadget paragraph new-gadget
{ 1 0 } over (>>orientation) { 1 0 } >>orientation
[ (>>margin) ] keep ; swap >>margin ;
SYMBOL: x SYMBOL: max-x SYMBOL: x SYMBOL: max-x

2
basis/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -61,7 +61,7 @@ IN: ui.gadgets.scrollers.tests
<gadget> { 600 400 } >>dim "g1" set <gadget> { 600 400 } >>dim "g1" set
<gadget> { 600 10 } >>dim "g2" set <gadget> { 600 10 } >>dim "g2" set
"g2" get "g1" get swap add-gadget drop "g1" get "g2" get add-gadget drop
"g1" get <scroller> "g1" get <scroller>
{ 300 300 } >>dim { 300 300 } >>dim

32
basis/ui/gadgets/scrollers/scrollers.factor
View File

@ -33,17 +33,17 @@ scroller H{
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ; 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
: new-scroller ( gadget class -- scroller ) : new-scroller ( gadget class -- scroller )
new-frame new-frame
t >>root? t >>root?
<scroller-model> >>model <scroller-model> >>model
faint-boundary faint-boundary
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
swap over model>> <viewport> >>viewport
dup viewport>> @center grid-add ;
swap over model>> <viewport> >>viewport
dup viewport>> @center grid-add ;
: <scroller> ( gadget -- scroller ) scroller new-scroller ; : <scroller> ( gadget -- scroller ) scroller new-scroller ;
: scroll ( value scroller -- ) : scroll ( value scroller -- )
@ -81,7 +81,7 @@ scroller H{
: scroll>rect ( rect gadget -- ) : scroll>rect ( rect gadget -- )
dup find-scroller* dup [ dup find-scroller* dup [
[ relative-scroll-rect ] keep [ relative-scroll-rect ] keep
[ (>>follows) ] keep swap >>follows
relayout relayout
] [ ] [
3drop 3drop
@ -94,7 +94,7 @@ scroller H{
: scroll>gadget ( gadget -- ) : scroll>gadget ( gadget -- )
dup find-scroller* dup [ dup find-scroller* dup [
[ (>>follows) ] keep swap >>follows
relayout relayout
] [ ] [
2drop 2drop
@ -104,9 +104,7 @@ scroller H{
dup viewport>> viewport-dim { 0 1 } v* swap scroll ; dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
: scroll>bottom ( gadget -- ) : scroll>bottom ( gadget -- )
find-scroller [ find-scroller [ t >>follows relayout-1 ] when* ;
t over (>>follows) relayout-1
] when* ;
: scroll>top ( gadget -- ) : scroll>top ( gadget -- )
<zero-rect> swap scroll>rect ; <zero-rect> swap scroll>rect ;
@ -124,14 +122,14 @@ M: f update-scroller drop dup scroller-value swap scroll ;
M: scroller layout* M: scroller layout*
dup call-next-method dup call-next-method
dup follows>> dup follows>>
[ update-scroller ] 2keep 2dup update-scroller
swap (>>follows) ; >>follows drop ;
M: scroller focusable-child* M: scroller focusable-child*
viewport>> ; viewport>> ;
M: scroller model-changed M: scroller model-changed
nip f swap (>>follows) ; nip f >>follows drop ;
TUPLE: limited-scroller < scroller fixed-dim ; TUPLE: limited-scroller < scroller fixed-dim ;

30
basis/ui/gadgets/sliders/sliders.factor
View File

@ -46,7 +46,7 @@ M: slider model-changed nip elevator>> relayout-1 ;
TUPLE: thumb < gadget ; TUPLE: thumb < gadget ;
: begin-drag ( thumb -- ) : begin-drag ( thumb -- )
find-slider dup slider-value swap (>>saved) ; find-slider dup slider-value >>saved drop ;
: do-drag ( thumb -- ) : do-drag ( thumb -- )
find-slider drag-loc over orientation>> v. find-slider drag-loc over orientation>> v.
@ -83,7 +83,7 @@ thumb H{
dup direction>> swap find-slider slide-by-page ; dup direction>> swap find-slider slide-by-page ;
: elevator-click ( elevator -- ) : elevator-click ( elevator -- )
dup compute-direction over (>>direction) dup compute-direction >>direction
elevator-hold ; elevator-hold ;
elevator H{ elevator H{
@ -123,13 +123,13 @@ M: elevator layout*
: <slide-button> ( vector polygon amount -- button ) : <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r> >r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button> [ swap find-slider slide-by-line ] curry <repeat-button>
[ (>>orientation) ] keep ; swap >>orientation ;
: elevator, ( gadget orientation -- gadget ) : elevator, ( gadget orientation -- gadget )
tuck <elevator> >>elevator tuck <elevator> >>elevator
swap <thumb> >>thumb swap <thumb> >>thumb
dup elevator>> over thumb>> add-gadget dup elevator>> over thumb>> add-gadget
@center grid-add ; @center grid-add ;
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ; : <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ; : <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
@ -143,16 +143,16 @@ M: elevator layout*
32 >>line ; 32 >>line ;
: <x-slider> ( range -- slider ) : <x-slider> ( range -- slider )
{ 1 0 } <slider> { 1 0 } <slider>
<left-button> @left grid-add <left-button> @left grid-add
{ 0 1 } elevator, { 0 1 } elevator,
<right-button> @right grid-add ; <right-button> @right grid-add ;
: <y-slider> ( range -- slider ) : <y-slider> ( range -- slider )
{ 0 1 } <slider> { 0 1 } <slider>
<up-button> @top grid-add <up-button> @top grid-add
{ 1 0 } elevator, { 1 0 } elevator,
<down-button> @bottom grid-add ; <down-button> @bottom grid-add ;
M: slider pref-dim* M: slider pref-dim*
dup call-next-method dup call-next-method

12
basis/ui/gadgets/slots/slots.factor
View File

@ -69,12 +69,12 @@ M: value-ref finish-editing
} define-command } define-command
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track { 0 1 } slot-editor new-track
swap >>ref swap >>ref
dup <toolbar> f track-add dup <toolbar> f track-add
<source-editor> >>text <source-editor> >>text
dup text>> <scroller> 1 track-add dup text>> <scroller> 1 track-add
dup revert ; dup revert ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ; M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;

14
basis/ui/gadgets/tracks/tracks-tests.factor
View File

@ -3,14 +3,14 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test
IN: ui.gadgets.tracks.tests IN: ui.gadgets.tracks.tests
[ { 100 100 } ] [ [ { 100 100 } ] [
{ 0 1 } <track> { 0 1 } <track>
<gadget> { 100 100 } >>dim 1 track-add <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 100 110 } ] [ [ { 100 110 } ] [
{ 0 1 } <track> { 0 1 } <track>
<gadget> { 10 10 } >>dim f track-add <gadget> { 10 10 } >>dim f track-add
<gadget> { 100 100 } >>dim 1 track-add <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test

51
basis/ui/gadgets/tracks/tracks.factor
View File

@ -9,23 +9,23 @@ IN: ui.gadgets.tracks
TUPLE: track < pack sizes ; TUPLE: track < pack sizes ;
: normalized-sizes ( track -- seq ) : normalized-sizes ( track -- seq )
sizes>> dup sift sum '[ dup [ _ / ] when ] map ; sizes>> dup sift sum '[ dup [ _ / ] when ] map ;
: init-track ( track -- track ) : init-track ( track -- track )
init-gadget init-gadget
V{ } clone >>sizes V{ } clone >>sizes
1 >>fill ; 1 >>fill ;
: new-track ( orientation class -- track ) : new-track ( orientation class -- track )
new new
init-track init-track
swap >>orientation ; swap >>orientation ;
: <track> ( orientation -- track ) track new-track ; : <track> ( orientation -- track ) track new-track ;
: alloted-dim ( track -- dim ) : alloted-dim ( track -- dim )
[ children>> ] [ sizes>> ] bi { 0 0 } [ children>> ] [ sizes>> ] bi { 0 0 }
[ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ; [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ; : available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
@ -38,29 +38,26 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ; : track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
: track-pref-dims-2 ( track -- dim ) : track-pref-dims-2 ( track -- dim )
[ children>> pref-dims ] [ normalized-sizes ] bi [ children>> pref-dims ] [ normalized-sizes ] bi
[ [ v/n ] when* ] 2map [ [ v/n ] when* ] 2map
max-dim max-dim
[ >fixnum ] map ; [ >fixnum ] map ;
M: track pref-dim* ( gadget -- dim ) M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ] [ track-pref-dims-1 ]
[ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ] [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
[ orientation>> ] [ orientation>> ]
tri tri
set-axis ; set-axis ;
: track-add ( track gadget constraint -- track ) : track-add ( track gadget constraint -- track )
pick sizes>> push add-gadget ; pick sizes>> push add-gadget ;
: track-remove ( track gadget -- track ) : track-remove ( track gadget -- track )
dupd dup dupd dup [
[ [ swap children>> index ]
[ swap children>> index ] [ unparent sizes>> ] 2bi
[ unparent sizes>> ] 2bi delete-nth
delete-nth ] [ 2drop ] if ;
]
[ 2drop ]
if ;
: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ; : clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;

2
basis/ui/gadgets/viewports/viewports.factor
View File

@ -18,7 +18,7 @@ TUPLE: viewport < gadget ;
viewport new-gadget viewport new-gadget
swap >>model swap >>model
t >>clipped? t >>clipped?
[ swap add-gadget drop ] keep ; swap add-gadget ;
M: viewport layout* M: viewport layout*
dup rect-dim viewport-gap 2 v*n v- dup rect-dim viewport-gap 2 v*n v-

8
basis/ui/gadgets/worlds/worlds-tests.factor
View File

@ -18,7 +18,7 @@ IN: ui.gadgets.worlds.tests
<gadget> "g1" set <gadget> "g1" set
<gadget> "g2" set <gadget> "g2" set
"g1" get "g2" get swap add-gadget drop "g2" get "g1" get add-gadget drop
[ ] [ [ ] [
"g2" get <test-world> "w" set "g2" get <test-world> "w" set
@ -33,8 +33,8 @@ IN: ui.gadgets.worlds.tests
<gadget> "g1" set <gadget> "g1" set
<gadget> "g2" set <gadget> "g2" set
<gadget> "g3" set <gadget> "g3" set
"g1" get "g3" get swap add-gadget drop "g3" get "g1" get add-gadget drop
"g2" get "g3" get swap add-gadget drop "g3" get "g2" get add-gadget drop
[ ] [ [ ] [
"g3" get <test-world> "w" set "g3" get <test-world> "w" set
@ -55,7 +55,7 @@ TUPLE: focus-test < gadget ;
: <focus-test> : <focus-test>
focus-test new-gadget focus-test new-gadget
<focusing> over swap add-gadget drop ; dup <focusing> add-gadget drop ;
M: focus-test focusable-child* gadget-child ; M: focus-test focusable-child* gadget-child ;

2
basis/ui/gadgets/worlds/worlds.factor
View File

@ -89,7 +89,7 @@ SYMBOL: ui-error-hook
(draw-world) (draw-world)
] [ ] [
over <world-error> ui-error over <world-error> ui-error
f swap (>>active?) f >>active? drop
] recover ] recover
] with-variable ] with-variable
] [ ] [

13
basis/ui/operations/operations.factor
View File

@ -19,8 +19,7 @@ TUPLE: operation predicate command translator hook listener? ;
swap >>predicate ; swap >>predicate ;
PREDICATE: listener-operation < operation PREDICATE: listener-operation < operation
dup command>> listener-command? [ command>> listener-command? ] [ listener?>> ] bi or ;
swap listener?>> or ;
M: operation command-name M: operation command-name
command>> command-name ; command>> command-name ;
@ -59,15 +58,15 @@ SYMBOL: operations
: modify-operation ( hook translator operation -- operation ) : modify-operation ( hook translator operation -- operation )
clone clone
tuck (>>translator) swap >>translator
tuck (>>hook) swap >>hook
t over (>>listener?) ; t >>listener? ;
: modify-operations ( operations hook translator -- operations ) : modify-operations ( operations hook translator -- operations )
rot [ >r 2dup r> modify-operation ] map 2nip ; rot [ modify-operation ] with with map ;
: operations>commands ( object hook translator -- pairs ) : operations>commands ( object hook translator -- pairs )
>r >r object-operations r> r> modify-operations [ object-operations ] 2dip modify-operations
[ [ operation-gesture ] keep ] { } map>assoc ; [ [ operation-gesture ] keep ] { } map>assoc ;
: define-operation-map ( class group blurb object hook translator -- ) : define-operation-map ( class group blurb object hook translator -- )

2
basis/ui/render/render.factor
View File

@ -139,7 +139,7 @@ M: polygon draw-interior
: <polygon-gadget> ( color points -- gadget ) : <polygon-gadget> ( color points -- gadget )
dup max-dim dup max-dim
>r <polygon> <gadget> r> >>dim >r <polygon> <gadget> r> >>dim
[ (>>interior) ] keep ; swap >>interior ;
! Font rendering ! Font rendering
SYMBOL: font-renderer SYMBOL: font-renderer

10
basis/ui/tools/browser/browser.factor
View File

@ -20,11 +20,11 @@ TUPLE: browser-gadget < track pane history ;
"handbook" >link <history> >>history drop ; "handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track { 0 1 } browser-gadget new-track
dup init-history dup init-history
dup <toolbar> f track-add dup <toolbar> f track-add
dup <help-pane> >>pane dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;
M: browser-gadget call-tool* show-help ; M: browser-gadget call-tool* show-help ;

6
basis/ui/tools/deploy/deploy.factor
View File

@ -42,8 +42,8 @@ TUPLE: deploy-gadget < pack vocab settings ;
deploy-c-types? get "Retain all C types" <checkbox> add-gadget ; deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
: deploy-settings-theme ( gadget -- gadget ) : deploy-settings-theme ( gadget -- gadget )
{ 10 10 } >>gap { 10 10 } >>gap
1 >>fill ; 1 >>fill ;
: <deploy-settings> ( vocab -- control ) : <deploy-settings> ( vocab -- control )
default-config [ <model> ] assoc-map default-config [ <model> ] assoc-map
@ -57,7 +57,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
advanced-settings advanced-settings
deploy-settings-theme deploy-settings-theme
namespace <mapping> over (>>model) namespace <mapping> >>model
] ]
bind ; bind ;

10
basis/ui/tools/inspector/inspector.factor
View File

@ -16,11 +16,11 @@ TUPLE: inspector-gadget < track object pane ;
] with-pane ; ] with-pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track { 0 1 } inspector-gadget new-track
dup <toolbar> f track-add dup <toolbar> f track-add
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;
: inspect-object ( obj mirror keys inspector -- ) : inspect-object ( obj mirror keys inspector -- )
2nip swap >>object refresh ; 2nip swap >>object refresh ;

2
basis/ui/tools/listener/listener-tests.factor
View File

@ -15,7 +15,7 @@ IN: ui.tools.listener.tests
[ "dup" ] [ [ "dup" ] [
\ dup word-completion-string \ dup word-completion-string
] unit-test ] unit-test
[ "equal?" ] [ "equal?" ]
[ \ array \ equal? method word-completion-string ] unit-test [ \ array \ equal? method word-completion-string ] unit-test

37
basis/ui/tools/listener/listener.factor
View File

@ -13,8 +13,8 @@ IN: ui.tools.listener
TUPLE: listener-gadget < track input output stack ; TUPLE: listener-gadget < track input output stack ;
: listener-output, ( listener -- listener ) : listener-output, ( listener -- listener )
<scrolling-pane> >>output <scrolling-pane> >>output
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ; dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
: listener-streams ( listener -- input output ) : listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ; [ input>> ] [ output>> <pane-stream> ] bi ;
@ -23,15 +23,15 @@ TUPLE: listener-gadget < track input output stack ;
output>> <pane-stream> <interactor> ; output>> <pane-stream> <interactor> ;
: listener-input, ( listener -- listener ) : listener-input, ( listener -- listener )
dup <listener-input> >>input dup <listener-input> >>input
dup input>> dup input>>
{ 0 100 } <limited-scroller> { 0 100 } <limited-scroller>
"Input" <labelled-gadget> "Input" <labelled-gadget>
f track-add ; f track-add ;
: welcome. ( -- ) : welcome. ( -- )
"If this is your first time with Factor, please read the " print "If this is your first time with Factor, please read the " print
"handbook" ($link) "." print nl ; "handbook" ($link) "." print nl ;
M: listener-gadget focusable-child* M: listener-gadget focusable-child*
input>> ; input>> ;
@ -121,11 +121,10 @@ M: engine-word word-completion-string
TUPLE: stack-display < track ; TUPLE: stack-display < track ;
: <stack-display> ( workspace -- gadget ) : <stack-display> ( workspace -- gadget )
listener>> listener>>
{ 0 1 } stack-display new-track { 0 1 } stack-display new-track
over <toolbar> f track-add over <toolbar> f track-add
swap swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add ; 1 track-add ;
M: stack-display tool-scroller M: stack-display tool-scroller
@ -166,14 +165,14 @@ M: stack-display tool-scroller
} cleave ; } cleave ;
: init-listener ( listener -- ) : init-listener ( listener -- )
f <model> swap (>>stack) ; f <model> >>stack drop ;
: <listener-gadget> ( -- gadget ) : <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track { 0 1 } listener-gadget new-track
dup init-listener dup init-listener
listener-output, listener-output,
listener-input, ; listener-input, ;
: listener-help ( -- ) "ui-listener" help-window ; : listener-help ( -- ) "ui-listener" help-window ;
\ listener-help H{ { +nullary+ t } } define-command \ listener-help H{ { +nullary+ t } } define-command

10
basis/ui/tools/profiler/profiler.factor
View File

@ -8,11 +8,11 @@ IN: ui.tools.profiler
TUPLE: profiler-gadget < track pane ; TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track { 0 1 } profiler-gadget new-track
dup <toolbar> f track-add dup <toolbar> f track-add
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- ) : with-profiler-pane ( gadget quot -- )
>r pane>> r> with-pane ; >r pane>> r> with-pane ;

2
basis/ui/tools/search/search-tests.factor
View File

@ -19,7 +19,7 @@ IN: ui.tools.search.tests
] with-grafted-gadget ; ] with-grafted-gadget ;
: test-live-search ( gadget quot -- ? ) : test-live-search ( gadget quot -- ? )
>r update-live-search dup assert-non-empty r> all? ; >r update-live-search dup assert-non-empty r> all? ;
[ t ] [ [ t ] [
"swp" all-words f <definition-search> "swp" all-words f <definition-search>

17
basis/ui/tools/search/search.factor
View File

@ -60,15 +60,14 @@ search-field H{
swap <list> ; swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget ) : <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track { 0 1 } live-search new-track
<search-field> >>field <search-field> >>field
dup field>> f track-add dup field>> f track-add
-roll <search-list> >>list -roll <search-list> >>list
dup list>> <scroller> 1 track-add dup list>> <scroller> 1 track-add
swap
swap over field>> set-editor-string
over field>> set-editor-string dup field>> end-of-document ;
dup field>> end-of-document ;
M: live-search focusable-child* field>> ; M: live-search focusable-child* field>> ;

2
basis/ui/tools/tools-tests.factor
View File

@ -7,7 +7,7 @@ IN: ui.tools.tests
[ f ] [ f ]
[ [
<gadget> 0 <model> >>model <workspace-tabs> children>> empty? <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
] unit-test ] unit-test
[ ] [ <workspace> "w" set ] unit-test [ ] [ <workspace> "w" set ] unit-test

43
basis/ui/tools/tools.factor
View File

@ -13,35 +13,30 @@ mirrors ;
IN: ui.tools IN: ui.tools
: <workspace-tabs> ( workspace -- tabs ) : <workspace-tabs> ( workspace -- tabs )
model>> model>>
"tool-switching" workspace command-map commands>> "tool-switching" workspace command-map commands>>
[ command-string ] { } assoc>map <enum> >alist [ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ; <toggle-buttons> ;
: <workspace-book> ( workspace -- gadget ) : <workspace-book> ( workspace -- gadget )
dup
dup <stack-display>
<stack-display> <browser-gadget>
<browser-gadget> <inspector-gadget>
<inspector-gadget> <profiler-gadget>
<profiler-gadget> 4array
4array swap model>> <book> ;
swap model>>
<book> ;
: <workspace> ( -- workspace ) : <workspace> ( -- workspace )
{ 0 1 } workspace new-track { 0 1 } workspace new-track
0 <model> >>model
<listener-gadget> >>listener
dup <workspace-book> >>book
0 <model> >>model dup <workspace-tabs> f track-add
<listener-gadget> >>listener dup book>> 1/5 track-add
dup <workspace-book> >>book dup listener>> 4/5 track-add
dup <toolbar> f track-add ;
dup <workspace-tabs> f track-add
dup book>> 1/5 track-add
dup listener>> 4/5 track-add
dup <toolbar> f track-add ;
: resize-workspace ( workspace -- ) : resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [ dup sizes>> over control-value zero? [

12
basis/ui/tools/traceback/traceback.factor
View File

@ -25,14 +25,14 @@ TUPLE: traceback-gadget < track ;
M: traceback-gadget pref-dim* drop { 550 600 } ; M: traceback-gadget pref-dim* drop { 550 600 } ;
: <traceback-gadget> ( model -- gadget ) : <traceback-gadget> ( model -- gadget )
{ 0 1 } traceback-gadget new-track { 0 1 } traceback-gadget new-track
swap >>model swap >>model
dup model>> dup model>>
{ 1 0 } <track> { 1 0 } <track>
over <datastack-display> 1/2 track-add over <datastack-display> 1/2 track-add
swap <retainstack-display> 1/2 track-add swap <retainstack-display> 1/2 track-add
1/3 track-add 1/3 track-add
dup model>> <callstack-display> 2/3 track-add dup model>> <callstack-display> 2/3 track-add

16
basis/ui/tools/workspace/workspace.factor
View File

@ -26,7 +26,7 @@ GENERIC: tool-scroller ( tool -- scroller )
M: gadget tool-scroller drop f ; M: gadget tool-scroller drop f ;
: find-tool ( class workspace -- index tool ) : find-tool ( class workspace -- index tool )
book>> children>> [ class eq? ] with find ; book>> children>> [ class eq? ] with find ;
: show-tool ( class workspace -- tool ) : show-tool ( class workspace -- tool )
[ find-tool swap ] keep book>> model>> [ find-tool swap ] keep book>> model>>
@ -55,15 +55,15 @@ M: gadget tool-scroller drop f ;
article-title open-window ; article-title open-window ;
: hide-popup ( workspace -- ) : hide-popup ( workspace -- )
dup popup>> track-remove dup popup>> track-remove
f >>popup f >>popup
request-focus ; request-focus ;
: show-popup ( gadget workspace -- ) : show-popup ( gadget workspace -- )
dup hide-popup dup hide-popup
over >>popup over >>popup
over f track-add drop over f track-add drop
request-focus ; request-focus ;
: show-titled-popup ( workspace gadget title -- ) : show-titled-popup ( workspace gadget title -- )
[ find-workspace hide-popup ] <closable-gadget> [ find-workspace hide-popup ] <closable-gadget>

17
basis/ui/ui.factor
View File

@ -51,12 +51,12 @@ SYMBOL: stop-after-last-window?
T{ gain-focus } swap each-gesture ; T{ gain-focus } swap each-gesture ;
: focus-world ( world -- ) : focus-world ( world -- )
t over (>>focused?) t >>focused?
dup raised-window dup raised-window
focus-path f focus-gestures ; focus-path f focus-gestures ;
: unfocus-world ( world -- ) : unfocus-world ( world -- )
f over (>>focused?) f >>focused?
focus-path f swap focus-gestures ; focus-path f swap focus-gestures ;
M: world graft* M: world graft*
@ -69,7 +69,7 @@ M: world graft*
#! when restoring saved worlds on image startup. #! when restoring saved worlds on image startup.
dup fonts>> clear-assoc dup fonts>> clear-assoc
dup unfocus-world dup unfocus-world
f swap (>>handle) ; f >>handle drop ;
M: world ungraft* M: world ungraft*
dup free-fonts dup free-fonts
@ -93,13 +93,8 @@ SYMBOL: ui-hook
dup graft-state>> { dup graft-state>> {
{ { f f } [ ] } { { f f } [ ] }
{ { f t } [ ] } { { f t } [ ] }
{ { t t } [ { { t t } [ { f f } >>graft-state ] }
{ f f } over (>>graft-state) { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
] }
{ { t f } [
dup unqueue-graft
{ f f } over (>>graft-state)
] }
} case graft-later ; } case graft-later ;
: restore-gadget ( gadget -- ) : restore-gadget ( gadget -- )
@ -172,7 +167,7 @@ SYMBOL: ui-thread
"UI update" spawn drop ; "UI update" spawn drop ;
: open-world-window ( world -- ) : open-world-window ( world -- )
dup pref-dim over (>>dim) dup relayout graft ; dup pref-dim >>dim dup relayout graft ;
: open-window ( gadget title -- ) : open-window ( gadget title -- )
f <world> open-world-window ; f <world> open-world-window ;

6
basis/ui/x11/x11.factor
View File

@ -21,8 +21,8 @@ C: <x11-handle> x11-handle
M: world expose-event nip relayout ; M: world expose-event nip relayout ;
M: world configure-event M: world configure-event
over configured-loc over (>>window-loc) over configured-loc >>window-loc
swap configured-dim over (>>dim) swap configured-dim >>dim
! In case dimensions didn't change ! In case dimensions didn't change
relayout-1 ; relayout-1 ;
@ -173,7 +173,7 @@ M: world client-event
dup window-loc>> over rect-dim glx-window dup window-loc>> over rect-dim glx-window
over "Factor" create-xic <x11-handle> over "Factor" create-xic <x11-handle>
2dup window>> register-window 2dup window>> register-window
swap (>>handle) ; >>handle drop ;
: wait-event ( -- event ) : wait-event ( -- event )
QueuedAfterFlush events-queued 0 > [ QueuedAfterFlush events-queued 0 > [

3
basis/unicode/breaks/breaks.factor
View File

@ -98,5 +98,4 @@ VALUE: grapheme-table
init-grapheme-table table init-grapheme-table table
[ make-grapheme-table finish-table ] with-variable [ make-grapheme-table finish-table ] with-variable
\ grapheme-table set-value to: grapheme-table

2
basis/unicode/collation/collation.factor
View File

@ -27,7 +27,7 @@ TUPLE: weight primary secondary tertiary ignorable? ;
[ parse-line ] H{ } map>assoc ; [ parse-line ] H{ } map>assoc ;
"resource:basis/unicode/collation/allkeys.txt" "resource:basis/unicode/collation/allkeys.txt"
ascii <file-reader> parse-ducet \ ducet set-value ascii <file-reader> parse-ducet to: ducet
! Fix up table for long contractions ! Fix up table for long contractions
: help-one ( assoc key -- ) : help-one ( assoc key -- )

22
basis/unicode/data/data.factor
View File

@ -164,18 +164,16 @@ C: <code-point> code-point
[ [ set-code-point ] each ] H{ } make-assoc ; [ [ set-code-point ] each ] H{ } make-assoc ;
load-data { load-data {
[ process-names \ name-map set-value ] [ process-names to: name-map ]
[ 13 swap process-data \ simple-lower set-value ] [ 13 swap process-data to: simple-lower ]
[ 12 swap process-data \ simple-upper set-value ] [ 12 swap process-data to: simple-upper ]
[ 14 swap process-data [ 14 swap process-data simple-upper assoc-union to: simple-title ]
simple-upper assoc-union \ simple-title set-value ] [ process-combining to: class-map ]
[ process-combining \ class-map set-value ] [ process-canonical to: canonical-map to: combine-map ]
[ process-canonical \ canonical-map set-value [ process-compatibility to: compatibility-map ]
\ combine-map set-value ] [ process-category to: category-map ]
[ process-compatibility \ compatibility-map set-value ]
[ process-category \ category-map set-value ]
} cleave } cleave
load-special-casing \ special-casing set-value load-special-casing to: special-casing
load-properties \ properties set-value load-properties to: properties

2
basis/unicode/script/script.factor
View File

@ -32,7 +32,7 @@ SYMBOL: interned
: process-script ( ranges -- ) : process-script ( ranges -- )
dup values prune >symbols interned [ dup values prune >symbols interned [
expand-ranges \ script-table set-value expand-ranges to: script-table
] with-variable ; ] with-variable ;
: load-script ( -- ) : load-script ( -- )

16
basis/values/values-docs.factor
View File

@ -7,6 +7,7 @@ ARTICLE: "values" "Global values"
"To get the value, just call the word. The following words manipulate values:" "To get the value, just call the word. The following words manipulate values:"
{ $subsection get-value } { $subsection get-value }
{ $subsection set-value } { $subsection set-value }
{ $subsection POSTPONE: to: }
{ $subsection change-value } ; { $subsection change-value } ;
HELP: VALUE: HELP: VALUE:
@ -20,8 +21,19 @@ HELP: get-value
HELP: set-value HELP: set-value
{ $values { "value" "a new value" } { "word" "a value word" } } { $values { "value" "a new value" } { "word" "a value word" } }
{ $description "Sets the value word." } ; { $description "Sets a value word." } ;
HELP: to:
{ $syntax "... to: value" }
{ $values { "word" "a value word" } }
{ $description "Sets a value word." }
{ $notes
"Note that"
{ $code "foo to: value" }
"is just sugar for"
{ $code "foo \\ value set-value" }
} ;
HELP: change-value HELP: change-value
{ $values { "word" "a value word" } { "quot" "a quotation ( oldvalue -- newvalue )" } } { $values { "word" "a value word" } { "quot" "a quotation with stack effect " { $snippet "( oldvalue -- newvalue )" } } }
{ $description "Changes the value using the given quotation." } ; { $description "Changes the value using the given quotation." } ;

2
basis/values/values-tests.factor
View File

@ -3,7 +3,7 @@ IN: values.tests
VALUE: foo VALUE: foo
[ f ] [ foo ] unit-test [ f ] [ foo ] unit-test
[ ] [ 3 \ foo set-value ] unit-test [ ] [ 3 to: foo ] unit-test
[ 3 ] [ foo ] unit-test [ 3 ] [ foo ] unit-test
[ ] [ \ foo [ 1+ ] change-value ] unit-test [ ] [ \ foo [ 1+ ] change-value ] unit-test
[ 4 ] [ foo ] unit-test [ 4 ] [ foo ] unit-test

37
basis/values/values.factor
View File

@ -1,15 +1,42 @@
USING: accessors kernel parser sequences words effects ; ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel parser words sequences quotations ;
IN: values IN: values
! Mutating literals in word definitions is not really allowed,
! and the deploy tool takes advantage of this fact to perform
! some aggressive stripping and compression. However, this
! breaks a naive implementation of values. We need to do two
! things:
! 1) Store the value in a subclass of identity-tuple, so that
! two quotations from different value words are never equal.
! This avoids bogus merging of values.
! 2) Set the "no-def-strip" word-prop, so that the shaker leaves
! the def>> slot alone, allowing us to introspect it. Otherwise,
! it will get set to [ ] and we would lose access to the
! value-holder.
<PRIVATE
TUPLE: value-holder < identity-tuple obj ;
PRIVATE>
: VALUE: : VALUE:
CREATE-WORD { f } clone [ first ] curry CREATE-WORD
dup t "no-def-strip" set-word-prop
T{ value-holder } clone [ obj>> ] curry
(( -- value )) define-declared ; parsing (( -- value )) define-declared ; parsing
: set-value ( value word -- ) : set-value ( value word -- )
def>> first set-first ; def>> first (>>obj) ;
: to:
scan-word literalize parsed
\ set-value parsed ; parsing
: get-value ( word -- value ) : get-value ( word -- value )
def>> first first ; def>> first obj>> ;
: change-value ( word quot -- ) : change-value ( word quot -- )
over >r >r get-value r> call r> set-value ; inline [ [ get-value ] dip call ] [ drop ] 2bi set-value ; inline

37
core/math/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private namespaces make sequences strings USING: kernel math.private namespaces sequences strings
arrays combinators splitting math assocs ; arrays combinators splitting math assocs make ;
IN: math.parser IN: math.parser
: digit> ( ch -- n ) : digit> ( ch -- n )
@ -94,10 +94,10 @@ PRIVATE>
: >digit ( n -- ch ) : >digit ( n -- ch )
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
: integer, ( num radix -- ) : positive>base ( num radix -- str )
dup 1 <= [ "Invalid radix" throw ] when dup 1 <= [ "Invalid radix" throw ] when
[ /mod >digit , ] keep over 0 > [ dup 0 > ] swap [ /mod >digit ] curry [ ] "" produce-as nip
[ integer, ] [ 2drop ] if ; dup reverse-here ; inline
PRIVATE> PRIVATE>
@ -110,24 +110,27 @@ GENERIC# >base 1 ( n radix -- str )
PRIVATE> PRIVATE>
M: integer >base M: integer >base
[ over 0 = [
over 0 < [ 2drop "0"
swap neg swap integer, CHAR: - , ] [
over 0 > [
positive>base
] [ ] [
integer, [ neg ] dip positive>base CHAR: - prefix
] if ] if
] "" make reverse ; ] if ;
M: ratio >base M: ratio >base
[ [
dup 0 < negative? set
1 /mod
[ dup zero? [ drop "" ] [ (>base) sign append ] if ]
[ [
dup 0 < dup negative? set [ "-" % neg ] when [ numerator (>base) ]
1 /mod [ denominator (>base) ] bi
>r dup zero? [ drop ] [ (>base) % sign % ] if r> "/" swap 3append
dup numerator (>base) % ] bi* append
"/" % negative? get [ CHAR: - prefix ] when
denominator (>base) %
] "" make
] with-radix ; ] with-radix ;
: fix-float ( str -- newstr ) : fix-float ( str -- newstr )

5
core/sequences/sequences.factor
View File

@ -454,8 +454,11 @@ PRIVATE>
: accumulator ( quot -- quot' vec ) : accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline V{ } clone [ [ push ] curry compose ] keep ; inline
: produce-as ( pred quot tail exemplar -- seq )
>r swap accumulator >r swap while r> r> like ; inline
: produce ( pred quot tail -- seq ) : produce ( pred quot tail -- seq )
swap accumulator >r swap while r> { } like ; inline { } produce-as ; inline
: follow ( obj quot -- seq ) : follow ( obj quot -- seq )
>r [ dup ] r> [ keep ] curry [ ] produce nip ; inline >r [ dup ] r> [ keep ] curry [ ] produce nip ; inline