Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
bb01491d60
|
|
@ -150,3 +150,6 @@ link-no-follow? off
|
|||
|
||||
[ "<p>paragraph\n a ___ b</p>" ]
|
||||
[ "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
|
||||
|
|
|
|||
|
|
@ -32,6 +32,6 @@ $nl
|
|||
$nl
|
||||
"It is also possible to override the hook used when serving static files to the client:"
|
||||
{ $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"
|
||||
|
|
|
|||
|
|
@ -59,4 +59,4 @@ PRIVATE>
|
|||
PRIVATE>
|
||||
|
||||
"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
|
||||
|
|
|
|||
|
|
@ -31,6 +31,6 @@ tools.test models.range ;
|
|||
|
||||
! should be able to move by a page of 10
|
||||
[ 10 ] [
|
||||
setup-range 10 over set-range-page-value
|
||||
1 over move-by-page range-value
|
||||
setup-range 10 over set-range-page-value
|
||||
1 over move-by-page range-value
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -123,7 +123,11 @@ PRIVATE>
|
|||
: callstack. ( callstack -- )
|
||||
callstack>array 2 <groups> [
|
||||
remove-breakpoints
|
||||
3 nesting-limit [ . ] with-variable
|
||||
[
|
||||
3 nesting-limit set
|
||||
100 length-limit set
|
||||
.
|
||||
] with-scope
|
||||
] assoc-each ;
|
||||
|
||||
: .c ( -- ) callstack callstack. ;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
@ -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"
|
||||
|
|
@ -102,12 +102,12 @@ TUPLE: entry title url description date ;
|
|||
{ "feed" [ atom1.0 ] }
|
||||
} case ;
|
||||
|
||||
: read-feed ( string -- feed )
|
||||
: string>feed ( string -- feed )
|
||||
[ string>xml xml>feed ] with-html-entities ;
|
||||
|
||||
: download-feed ( url -- feed )
|
||||
#! Retrieve an news syndication file, return as a feed tuple.
|
||||
http-get nip read-feed ;
|
||||
http-get nip string>feed ;
|
||||
|
||||
! Atom generation
|
||||
: simple-tag, ( content name -- )
|
||||
|
|
|
|||
|
|
@ -43,6 +43,11 @@ namespaces continuations layouts accessors ;
|
|||
|
||||
[ 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.2"
|
||||
|
|
@ -51,9 +56,7 @@ namespaces continuations layouts accessors ;
|
|||
} [
|
||||
[ ] swap [
|
||||
shake-and-bake
|
||||
vm
|
||||
"-i=" "test.image" temp-file append
|
||||
2array try-process
|
||||
run-temp-image
|
||||
] curry unit-test
|
||||
] each
|
||||
|
||||
|
|
@ -88,9 +91,12 @@ M: quit-responder call-responder*
|
|||
|
||||
[ ] [
|
||||
"tools.deploy.test.5" shake-and-bake
|
||||
vm
|
||||
"-i=" "test.image" temp-file append
|
||||
2array try-process
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.6" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 }
|
||||
}
|
||||
|
|
@ -16,15 +16,15 @@ M: book model-changed ( model book -- )
|
|||
relayout ;
|
||||
|
||||
: new-book ( pages model class -- book )
|
||||
new-gadget
|
||||
swap >>model
|
||||
swap add-gadgets ; inline
|
||||
new-gadget
|
||||
swap >>model
|
||||
swap add-gadgets ; inline
|
||||
|
||||
: <book> ( pages model -- book ) book new-book ;
|
||||
|
||||
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ TUPLE: border < gadget
|
|||
{ align initial: { 1/2 1/2 } } ;
|
||||
|
||||
: new-border ( child class -- border )
|
||||
new-gadget [ swap add-gadget drop ] keep ; inline
|
||||
new-gadget swap add-gadget ; inline
|
||||
|
||||
: <border> ( child gap -- border )
|
||||
swap border new-border
|
||||
|
|
@ -42,7 +42,8 @@ M: border pref-dim*
|
|||
M: border layout*
|
||||
dup border-child-rect swap gadget-child
|
||||
over loc>> >>loc
|
||||
swap dim>> swap (>>dim) ;
|
||||
swap dim>> >>dim
|
||||
drop ;
|
||||
|
||||
M: border focusable-child*
|
||||
gadget-child ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ TUPLE: button < border pressed? selected? quot ;
|
|||
dup mouse-clicked?
|
||||
over button-rollover? and
|
||||
buttons-down? and
|
||||
over (>>pressed?)
|
||||
>>pressed?
|
||||
relayout-1 ;
|
||||
|
||||
: if-clicked ( button quot -- )
|
||||
|
|
@ -115,20 +115,18 @@ M: checkmark-paint draw-interior
|
|||
dup { 0 1 } v* swap { 1 0 } v* gl-line
|
||||
] with-translation ;
|
||||
|
||||
: checkmark-theme ( gadget -- )
|
||||
: checkmark-theme ( gadget -- gadget )
|
||||
f
|
||||
f
|
||||
black <solid>
|
||||
black <checkmark-paint>
|
||||
<button-paint>
|
||||
over (>>interior)
|
||||
black <solid>
|
||||
swap (>>boundary) ;
|
||||
<button-paint> >>interior
|
||||
black <solid> >>boundary ;
|
||||
|
||||
: <checkmark> ( -- gadget )
|
||||
<gadget>
|
||||
dup checkmark-theme
|
||||
{ 14 14 } over (>>dim) ;
|
||||
checkmark-theme
|
||||
{ 14 14 } >>dim ;
|
||||
|
||||
: toggle-model ( model -- )
|
||||
[ not ] change-model ;
|
||||
|
|
@ -148,7 +146,7 @@ TUPLE: checkbox < button ;
|
|||
align-left ;
|
||||
|
||||
M: checkbox model-changed
|
||||
swap value>> over (>>selected?) relayout-1 ;
|
||||
swap value>> >>selected? relayout-1 ;
|
||||
|
||||
TUPLE: radio-paint color ;
|
||||
|
||||
|
|
@ -162,20 +160,18 @@ M: radio-paint draw-boundary
|
|||
color>> set-color
|
||||
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
|
||||
black <radio-paint>
|
||||
black <radio-paint>
|
||||
<button-paint>
|
||||
over (>>interior)
|
||||
black <radio-paint>
|
||||
swap (>>boundary) ;
|
||||
<button-paint> >>interior
|
||||
black <radio-paint> >>boundary ;
|
||||
|
||||
: <radio-knob> ( -- gadget )
|
||||
<gadget>
|
||||
dup radio-knob-theme
|
||||
{ 16 16 } over (>>dim) ;
|
||||
radio-knob-theme
|
||||
{ 16 16 } >>dim ;
|
||||
|
||||
TUPLE: radio-control < button value ;
|
||||
|
||||
|
|
@ -188,13 +184,12 @@ TUPLE: radio-control < button value ;
|
|||
|
||||
M: radio-control model-changed
|
||||
swap value>>
|
||||
over value>> =
|
||||
over (>>selected?)
|
||||
over value>> = >>selected?
|
||||
relayout-1 ;
|
||||
|
||||
: <radio-controls> ( parent model assoc quot -- parent )
|
||||
#! quot has stack effect ( value model label -- )
|
||||
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
|
||||
#! quot has stack effect ( value model label -- )
|
||||
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
|
||||
|
||||
: radio-button-theme ( gadget -- gadget )
|
||||
{ 5 5 } >>gap
|
||||
|
|
@ -204,18 +199,18 @@ M: radio-control model-changed
|
|||
<radio-knob> label-on-right radio-button-theme <radio-control> ;
|
||||
|
||||
: <radio-buttons> ( model assoc -- gadget )
|
||||
<filled-pile>
|
||||
-rot
|
||||
[ <radio-button> ] <radio-controls>
|
||||
{ 5 5 } >>gap ;
|
||||
<filled-pile>
|
||||
-rot
|
||||
[ <radio-button> ] <radio-controls>
|
||||
{ 5 5 } >>gap ;
|
||||
|
||||
: <toggle-button> ( value model label -- gadget )
|
||||
<radio-control> bevel-button-theme ;
|
||||
|
||||
: <toggle-buttons> ( model assoc -- gadget )
|
||||
<shelf>
|
||||
-rot
|
||||
[ <toggle-button> ] <radio-controls> ;
|
||||
<shelf>
|
||||
-rot
|
||||
[ <toggle-button> ] <radio-controls> ;
|
||||
|
||||
: command-button-quot ( target command -- quot )
|
||||
[ invoke-command drop ] 2curry ;
|
||||
|
|
@ -227,7 +222,7 @@ M: radio-control model-changed
|
|||
<bevel-button> ;
|
||||
|
||||
: <toolbar> ( target -- toolbar )
|
||||
<shelf>
|
||||
swap
|
||||
"toolbar" over class command-map commands>> swap
|
||||
[ -rot <command-button> add-gadget ] curry assoc-each ;
|
||||
<shelf>
|
||||
swap
|
||||
"toolbar" over class command-map commands>> swap
|
||||
[ -rot <command-button> add-gadget ] curry assoc-each ;
|
||||
|
|
|
|||
|
|
@ -96,9 +96,9 @@ M: editor ungraft*
|
|||
: click-loc ( editor 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 )
|
||||
swap head-slice string-width ;
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@ IN: ui.gadgets.tests
|
|||
! c contains b contains a
|
||||
<gadget> "a" set
|
||||
<gadget> "b" set
|
||||
"a" get "b" get swap add-gadget drop
|
||||
"b" get "a" get add-gadget drop
|
||||
<gadget> "c" set
|
||||
"b" get "c" get swap add-gadget drop
|
||||
"c" get "b" get add-gadget drop
|
||||
|
||||
! position a and b
|
||||
"a" get { 100 200 } >>loc drop
|
||||
|
|
@ -33,8 +33,8 @@ IN: ui.gadgets.tests
|
|||
<gadget> "g3" set
|
||||
"g3" get { 100 200 } >>dim drop
|
||||
|
||||
"g1" get "g2" get swap add-gadget drop
|
||||
"g2" get "g3" get swap add-gadget drop
|
||||
"g2" get "g1" get add-gadget drop
|
||||
"g3" get "g2" get add-gadget drop
|
||||
|
||||
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
|
||||
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
|
||||
|
|
@ -49,11 +49,11 @@ IN: ui.gadgets.tests
|
|||
<gadget> "g1" set
|
||||
"g1" get { 300 300 } >>dim drop
|
||||
<gadget> "g2" set
|
||||
"g2" get "g1" get swap add-gadget drop
|
||||
"g1" get "g2" get add-gadget drop
|
||||
"g2" get { 20 20 } >>loc
|
||||
{ 20 20 } >>dim drop
|
||||
<gadget> "g3" set
|
||||
"g3" get "g1" get swap add-gadget drop
|
||||
"g1" get "g3" get add-gadget drop
|
||||
"g3" get { 100 100 } >>loc
|
||||
{ 20 20 } >>dim drop
|
||||
|
||||
|
|
@ -66,7 +66,7 @@ IN: ui.gadgets.tests
|
|||
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
|
||||
|
||||
<gadget> "g4" set
|
||||
"g4" get "g2" get swap add-gadget drop
|
||||
"g2" get "g4" get add-gadget drop
|
||||
"g4" get { 5 5 } >>loc
|
||||
{ 1 1 } >>dim drop
|
||||
|
||||
|
|
@ -121,7 +121,7 @@ M: mock-gadget ungraft*
|
|||
: add-some-children
|
||||
3 [
|
||||
<mock-gadget> over <model> >>model
|
||||
dup "g" get swap add-gadget drop
|
||||
"g" get over add-gadget drop
|
||||
swap 1+ number>string set
|
||||
] each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -27,10 +27,10 @@ M: gadget model-changed 2drop ;
|
|||
: nth-gadget ( n gadget -- child ) children>> nth ;
|
||||
|
||||
: init-gadget ( gadget -- gadget )
|
||||
init-rect
|
||||
{ 0 1 } >>orientation
|
||||
t >>visible?
|
||||
{ f f } >>graft-state ; inline
|
||||
init-rect
|
||||
{ 0 1 } >>orientation
|
||||
t >>visible?
|
||||
{ f f } >>graft-state ; inline
|
||||
|
||||
: new-gadget ( class -- gadget ) new init-gadget ; inline
|
||||
|
||||
|
|
@ -132,9 +132,9 @@ M: array gadget-text*
|
|||
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
|
@ -147,7 +147,7 @@ M: array gadget-text*
|
|||
DEFER: relayout
|
||||
|
||||
: invalidate* ( gadget -- )
|
||||
\ invalidate* over (>>layout-state)
|
||||
\ invalidate* >>layout-state
|
||||
dup forget-pref-dim
|
||||
dup root?>>
|
||||
[ layout-later ] [ parent>> [ relayout ] when* ] if ;
|
||||
|
|
@ -160,20 +160,19 @@ DEFER: relayout
|
|||
dup layout-state>>
|
||||
[ drop ] [ dup invalidate layout-later ] if ;
|
||||
|
||||
: show-gadget ( gadget -- ) t swap (>>visible?) ;
|
||||
|
||||
: hide-gadget ( gadget -- ) f swap (>>visible?) ;
|
||||
: show-gadget ( gadget -- ) t >>visible? drop ;
|
||||
|
||||
: hide-gadget ( gadget -- ) f >>visible? drop ;
|
||||
|
||||
DEFER: in-layout?
|
||||
|
||||
: do-invalidate ( gadget -- gadget )
|
||||
in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
|
||||
GENERIC: dim-changed ( gadget -- )
|
||||
|
||||
M: gadget dim-changed
|
||||
in-layout? get [ invalidate ] [ invalidate* ] if ;
|
||||
|
||||
M: gadget (>>dim) ( dim gadget -- )
|
||||
2dup dim>> =
|
||||
[ 2drop ]
|
||||
[ tuck call-next-method do-invalidate drop ]
|
||||
if ;
|
||||
2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
|
||||
|
||||
GENERIC: pref-dim* ( gadget -- dim )
|
||||
|
||||
|
|
@ -194,9 +193,9 @@ GENERIC: layout* ( gadget -- )
|
|||
|
||||
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 -- )
|
||||
dup layout-state>> [
|
||||
|
|
@ -255,11 +254,10 @@ M: gadget ungraft* drop ;
|
|||
: (unparent) ( gadget -- )
|
||||
dup ungraft
|
||||
dup forget-pref-dim
|
||||
f swap (>>parent) ;
|
||||
f >>parent drop ;
|
||||
|
||||
: unfocus-gadget ( child gadget -- )
|
||||
tuck focus>> eq?
|
||||
[ f swap (>>focus) ] [ drop ] if ;
|
||||
tuck focus>> eq? [ f >>focus ] when drop ;
|
||||
|
||||
SYMBOL: in-layout?
|
||||
|
||||
|
|
@ -282,8 +280,7 @@ SYMBOL: in-layout?
|
|||
|
||||
: (clear-gadget) ( gadget -- )
|
||||
dup [ (unparent) ] each-child
|
||||
f over (>>focus)
|
||||
f swap (>>children) ;
|
||||
f >>focus f >>children drop ;
|
||||
|
||||
: clear-gadget ( gadget -- )
|
||||
not-in-layout
|
||||
|
|
@ -305,7 +302,7 @@ SYMBOL: in-layout?
|
|||
not-in-layout
|
||||
(add-gadget)
|
||||
dup relayout ;
|
||||
|
||||
|
||||
: add-gadgets ( parent children -- parent )
|
||||
not-in-layout
|
||||
[ (add-gadget) ] each
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math namespaces make sequences words io
|
||||
io.streams.string math.vectors ui.gadgets columns accessors
|
||||
math.geometry.rect ;
|
||||
math.geometry.rect locals ;
|
||||
IN: ui.gadgets.grids
|
||||
|
||||
TUPLE: grid < gadget
|
||||
|
|
@ -12,18 +12,18 @@ grid
|
|||
|
||||
: new-grid ( children class -- grid )
|
||||
new-gadget
|
||||
[ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
|
||||
inline
|
||||
swap >>grid
|
||||
dup grid>> concat add-gadgets ; inline
|
||||
|
||||
: <grid> ( children -- grid )
|
||||
grid new-grid ;
|
||||
|
||||
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
|
||||
|
||||
: grid-add ( grid child i j -- grid )
|
||||
>r >r dupd swap r> r>
|
||||
>r >r 2dup swap add-gadget drop r> r>
|
||||
3dup grid-child unparent rot grid>> nth set-nth ;
|
||||
:: grid-add ( grid child i j -- grid )
|
||||
grid i j grid-child unparent
|
||||
grid child add-gadget
|
||||
child i j grid grid>> nth set-nth ;
|
||||
|
||||
: 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 -- 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 )
|
||||
>r first r> second 2array ;
|
||||
[ first ] [ second ] bi* 2array ;
|
||||
|
||||
: pair-up ( horiz vert -- dims )
|
||||
[ [ (pair-up) ] curry map ] with map ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ $nl
|
|||
$nl
|
||||
"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
|
||||
$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>
|
||||
{ $values { "incremental" "a new instance of " { $link incremental } } }
|
||||
|
|
|
|||
|
|
@ -4,17 +4,6 @@ USING: io kernel math namespaces math.vectors ui.gadgets
|
|||
ui.gadgets.packs accessors math.geometry.rect ;
|
||||
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 ;
|
||||
|
||||
: <incremental> ( -- incremental )
|
||||
|
|
@ -24,38 +13,42 @@ TUPLE: incremental < pack cursor ;
|
|||
|
||||
M: incremental pref-dim*
|
||||
dup layout-state>> [
|
||||
dup call-next-method over (>>cursor)
|
||||
dup call-next-method >>cursor
|
||||
] when cursor>> ;
|
||||
|
||||
: next-cursor ( gadget incremental -- cursor )
|
||||
[
|
||||
swap rect-dim swap cursor>>
|
||||
2dup v+ >r vmax r>
|
||||
[ rect-dim ] [ cursor>> ] bi*
|
||||
[ vmax ] [ v+ ] 2bi
|
||||
] keep orientation>> set-axis ;
|
||||
|
||||
: update-cursor ( gadget incremental -- )
|
||||
[ next-cursor ] keep (>>cursor) ;
|
||||
tuck next-cursor >>cursor drop ;
|
||||
|
||||
: incremental-loc ( gadget incremental -- )
|
||||
[ cursor>> ] [ orientation>> ] bi v*
|
||||
>>loc drop ;
|
||||
|
||||
: prefer-incremental ( gadget -- )
|
||||
: prefer-incremental ( gadget -- ) USE: slots.private
|
||||
dup forget-pref-dim dup pref-dim >>dim drop ;
|
||||
|
||||
M: incremental dim-changed drop ;
|
||||
|
||||
: add-incremental ( gadget incremental -- )
|
||||
not-in-layout
|
||||
2dup swap (add-gadget) drop
|
||||
over prefer-incremental
|
||||
over layout-later
|
||||
2dup incremental-loc
|
||||
tuck update-cursor
|
||||
dup prefer-incremental
|
||||
parent>> [ invalidate* ] when* ;
|
||||
t in-layout? [
|
||||
over prefer-incremental
|
||||
over layout-later
|
||||
2dup incremental-loc
|
||||
tuck update-cursor
|
||||
dup prefer-incremental
|
||||
parent>> [ invalidate* ] when*
|
||||
] with-variable ;
|
||||
|
||||
: clear-incremental ( incremental -- )
|
||||
not-in-layout
|
||||
dup (clear-gadget)
|
||||
dup forget-pref-dim
|
||||
{ 0 0 } over (>>cursor)
|
||||
{ 0 0 } >>cursor
|
||||
parent>> [ relayout ] when* ;
|
||||
|
|
|
|||
|
|
@ -11,10 +11,10 @@ IN: ui.gadgets.labelled
|
|||
TUPLE: labelled-gadget < track content ;
|
||||
|
||||
: <labelled-gadget> ( gadget title -- newgadget )
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
swap <label> reverse-video-theme f track-add
|
||||
swap >>content
|
||||
dup content>> 1 track-add ;
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
swap <label> reverse-video-theme f track-add
|
||||
swap >>content
|
||||
dup content>> 1 track-add ;
|
||||
|
||||
M: labelled-gadget focusable-child* content>> ;
|
||||
|
||||
|
|
@ -22,25 +22,25 @@ M: labelled-gadget focusable-child* content>> ;
|
|||
>r <scroller> r> <labelled-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> ;
|
||||
|
||||
: <close-box> ( quot -- button/f )
|
||||
gray close-box <polygon-gadget> swap <bevel-button> ;
|
||||
|
||||
: title-theme ( gadget -- )
|
||||
{ 1 0 } over (>>orientation)
|
||||
: title-theme ( gadget -- gadget )
|
||||
{ 1 0 } >>orientation
|
||||
T{ gradient f {
|
||||
T{ rgba f 0.65 0.65 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 )
|
||||
<frame>
|
||||
swap dup [ <close-box> @left grid-add ] [ drop ] if
|
||||
swap <title-label> @center grid-add ;
|
||||
<frame>
|
||||
swap dup [ <close-box> @left grid-add ] [ drop ] if
|
||||
swap <title-label> @center grid-add ;
|
||||
|
||||
TUPLE: closable-gadget < frame content ;
|
||||
|
||||
|
|
@ -48,9 +48,9 @@ TUPLE: closable-gadget < frame content ;
|
|||
[ closable-gadget? ] find-parent ;
|
||||
|
||||
: <closable-gadget> ( gadget title quot -- gadget )
|
||||
closable-gadget new-frame
|
||||
-rot <title-bar> @top grid-add
|
||||
swap >>content
|
||||
dup content>> @center grid-add ;
|
||||
closable-gadget new-frame
|
||||
-rot <title-bar> @top grid-add
|
||||
swap >>content
|
||||
dup content>> @center grid-add ;
|
||||
|
||||
M: closable-gadget focusable-child* content>> ;
|
||||
|
|
|
|||
|
|
@ -63,11 +63,11 @@ M: object >label ;
|
|||
M: f >label drop <gadget> ;
|
||||
|
||||
: label-on-left ( gadget label -- button )
|
||||
{ 1 0 } <track>
|
||||
swap >label f track-add
|
||||
swap 1 track-add ;
|
||||
|
||||
{ 1 0 } <track>
|
||||
swap >label f track-add
|
||||
swap 1 track-add ;
|
||||
|
||||
: label-on-right ( label gadget -- button )
|
||||
{ 1 0 } <track>
|
||||
swap f track-add
|
||||
swap >label 1 track-add ;
|
||||
{ 1 0 } <track>
|
||||
swap f track-add
|
||||
swap >label 1 track-add ;
|
||||
|
|
|
|||
|
|
@ -27,8 +27,7 @@ TUPLE: list < pack index presenter color hook ;
|
|||
control-value length 1- min 0 max ;
|
||||
|
||||
: bound-index ( list -- )
|
||||
dup index>> over calc-bounded-index
|
||||
swap (>>index) ;
|
||||
dup index>> over calc-bounded-index >>index drop ;
|
||||
|
||||
: list-presentation-hook ( list -- quot )
|
||||
hook>> [ [ list? ] find-parent ] prepend ;
|
||||
|
|
@ -49,7 +48,7 @@ TUPLE: list < pack index presenter color hook ;
|
|||
M: list model-changed
|
||||
nip
|
||||
dup clear-gadget
|
||||
dup <list-items> over swap add-gadgets drop
|
||||
dup <list-items> add-gadgets
|
||||
bound-index ;
|
||||
|
||||
: selected-rect ( list -- rect )
|
||||
|
|
@ -79,8 +78,8 @@ M: list focusable-child* drop t ;
|
|||
2drop
|
||||
] [
|
||||
[ control-value length rem ] keep
|
||||
[ (>>index) ] keep
|
||||
[ relayout-1 ] keep
|
||||
swap >>index
|
||||
dup relayout-1
|
||||
scroll>selected
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -15,19 +15,17 @@ TUPLE: menu-glass < gadget ;
|
|||
: <menu-glass> ( menu world -- glass )
|
||||
menu-glass new-gadget
|
||||
>r over menu-loc >>loc r>
|
||||
[ swap add-gadget drop ] keep ;
|
||||
swap add-gadget ;
|
||||
|
||||
M: menu-glass layout* gadget-child prefer ;
|
||||
|
||||
: hide-glass ( world -- )
|
||||
dup glass>> [ unparent ] when*
|
||||
f swap (>>glass) ;
|
||||
[ [ unparent ] when* f ] change-glass drop ;
|
||||
|
||||
: show-glass ( gadget world -- )
|
||||
over hand-clicked set-global
|
||||
[ hide-glass ] keep
|
||||
[ swap add-gadget drop ] 2keep
|
||||
(>>glass) ;
|
||||
dup hide-glass
|
||||
swap [ hand-clicked set-global ] [ >>glass ] bi
|
||||
dup glass>> add-gadget drop ;
|
||||
|
||||
: show-menu ( gadget owner -- )
|
||||
find-world [ <menu-glass> ] keep show-glass ;
|
||||
|
|
@ -48,7 +46,7 @@ M: menu-glass layout* gadget-child prefer ;
|
|||
faint-boundary ;
|
||||
|
||||
: <commands-menu> ( hook target commands -- gadget )
|
||||
<filled-pile>
|
||||
-roll
|
||||
[ <menu-item> add-gadget ] with with each
|
||||
5 <border> menu-theme ;
|
||||
<filled-pile>
|
||||
-roll
|
||||
[ <menu-item> add-gadget ] with with each
|
||||
5 <border> menu-theme ;
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@ math.vectors namespaces math.order accessors math.geometry.rect ;
|
|||
IN: ui.gadgets.packs
|
||||
|
||||
TUPLE: pack < gadget
|
||||
{ align initial: 0 }
|
||||
{ fill initial: 0 }
|
||||
{ gap initial: { 0 0 } } ;
|
||||
{ align initial: 0 }
|
||||
{ fill initial: 0 }
|
||||
{ gap initial: { 0 0 } } ;
|
||||
|
||||
: packed-dim-2 ( gadget sizes -- list )
|
||||
[ over rect-dim over v- rot fill>> v*n v+ ] with map ;
|
||||
|
|
@ -40,7 +40,7 @@ TUPLE: pack < gadget
|
|||
|
||||
: <pile> ( -- pack ) { 0 1 } <pack> ;
|
||||
|
||||
: <filled-pile> ( -- pack ) <pile> 1 over (>>fill) ;
|
||||
: <filled-pile> ( -- pack ) <pile> 1 >>fill ;
|
||||
|
||||
: <shelf> ( -- pack ) { 1 0 } <pack> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,45 +1,51 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
|
||||
ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
|
||||
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
|
||||
hashtables io kernel namespaces sequences io.styles strings
|
||||
quotations math opengl combinators math.vectors
|
||||
sorting splitting io.streams.nested assocs
|
||||
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
|
||||
ui.gadgets.grid-lines classes.tuple models continuations
|
||||
destructors accessors math.geometry.rect ;
|
||||
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
|
||||
ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
|
||||
ui.clipboards ui.gestures ui.traverse ui.render hashtables io
|
||||
kernel namespaces sequences io.styles strings quotations math
|
||||
opengl combinators math.vectors sorting splitting
|
||||
io.streams.nested assocs ui.gadgets.presentations
|
||||
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
|
||||
classes.tuple models continuations destructors accessors
|
||||
math.geometry.rect ;
|
||||
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
TUPLE: pane < pack
|
||||
output current prototype scrolls?
|
||||
selection-color caret mark selecting? ;
|
||||
output current prototype scrolls?
|
||||
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-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
|
||||
: add-output ( pane current -- pane )
|
||||
[ >>output ] [ add-gadget ] bi ;
|
||||
|
||||
: add-current ( pane current -- pane )
|
||||
[ >>current ] [ add-gadget ] bi ;
|
||||
|
||||
: prepare-line ( pane -- pane )
|
||||
clear-selection
|
||||
dup prototype>> clone add-current ;
|
||||
clear-selection
|
||||
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 )
|
||||
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
|
||||
|
||||
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 -- )
|
||||
clear-selection
|
||||
[ output>> clear-incremental ]
|
||||
[ current>> clear-gadget ]
|
||||
bi ;
|
||||
clear-selection
|
||||
[ output>> clear-incremental ]
|
||||
[ current>> clear-gadget ]
|
||||
bi ;
|
||||
|
||||
: new-pane ( class -- pane )
|
||||
new-gadget
|
||||
|
|
@ -109,7 +115,7 @@ C: <pane-stream> pane-stream
|
|||
GENERIC: write-gadget ( gadget 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
|
||||
stream>> write-gadget ;
|
||||
|
|
@ -132,12 +138,12 @@ M: style-stream write-gadget
|
|||
: make-pane ( quot -- gadget )
|
||||
<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 ;
|
||||
|
||||
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 new-pane
|
||||
|
|
@ -172,7 +178,7 @@ M: pane-stream make-span-stream
|
|||
>r pick at r> when* ; inline
|
||||
|
||||
: apply-foreground-style ( style gadget -- style gadget )
|
||||
foreground [ over (>>color) ] apply-style ;
|
||||
foreground [ >>color ] apply-style ;
|
||||
|
||||
: apply-background-style ( style gadget -- style gadget )
|
||||
background [ solid-interior ] apply-style ;
|
||||
|
|
@ -183,7 +189,7 @@ M: pane-stream make-span-stream
|
|||
font-size swap at 12 or 3array ;
|
||||
|
||||
: apply-font-style ( style gadget -- style gadget )
|
||||
over specified-font over (>>font) ;
|
||||
over specified-font >>font ;
|
||||
|
||||
: apply-presentation-style ( style gadget -- style gadget )
|
||||
presented [ <presentation> ] apply-style ;
|
||||
|
|
@ -254,15 +260,15 @@ M: pane-stream make-block-stream
|
|||
|
||||
! Tables
|
||||
: 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 )
|
||||
table-border [ <grid-lines> over (>>boundary) ]
|
||||
table-border [ <grid-lines> >>boundary ]
|
||||
apply-style ;
|
||||
|
||||
: styled-grid ( style grid -- grid )
|
||||
<grid>
|
||||
f over (>>fill?)
|
||||
f >>fill?
|
||||
apply-table-gap-style
|
||||
apply-table-border-style
|
||||
nip ;
|
||||
|
|
@ -286,13 +292,13 @@ M: pack dispose drop ;
|
|||
M: paragraph dispose drop ;
|
||||
|
||||
: gadget-write ( string gadget -- )
|
||||
over empty?
|
||||
[ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
|
||||
swap dup empty?
|
||||
[ 2drop ] [ <label> text-theme add-gadget drop ] if ;
|
||||
|
||||
M: pack stream-write gadget-write ;
|
||||
|
||||
: 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
|
||||
swap " " split
|
||||
|
|
@ -309,8 +315,8 @@ M: paragraph stream-write1
|
|||
[ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
|
||||
|
||||
: gadget-format ( string style stream -- )
|
||||
pick empty?
|
||||
[ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
|
||||
spin dup empty?
|
||||
[ 3drop ] [ <styled-label> add-gadget drop ] if ;
|
||||
|
||||
M: pack stream-format
|
||||
gadget-format ;
|
||||
|
|
@ -326,13 +332,13 @@ M: paragraph stream-format
|
|||
] if ;
|
||||
|
||||
: caret>mark ( pane -- pane )
|
||||
dup caret>> >>mark
|
||||
dup relayout-1 ;
|
||||
dup caret>> >>mark
|
||||
dup relayout-1 ;
|
||||
|
||||
GENERIC: 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*
|
||||
children>> [ inside? ] with find-last drop ;
|
||||
|
|
@ -350,12 +356,10 @@ M: f sloppy-pick-up*
|
|||
if ;
|
||||
|
||||
: move-caret ( pane -- pane )
|
||||
dup hand-rel
|
||||
over sloppy-pick-up
|
||||
over (>>caret)
|
||||
dup relayout-1 ;
|
||||
dup hand-rel over sloppy-pick-up >>caret
|
||||
dup relayout-1 ;
|
||||
|
||||
: begin-selection ( pane -- ) move-caret f swap (>>mark) ;
|
||||
: begin-selection ( pane -- ) move-caret f >>mark drop ;
|
||||
|
||||
: extend-selection ( pane -- )
|
||||
hand-moved? [
|
||||
|
|
|
|||
|
|
@ -17,8 +17,8 @@ TUPLE: paragraph < gadget margin ;
|
|||
|
||||
: <paragraph> ( margin -- gadget )
|
||||
paragraph new-gadget
|
||||
{ 1 0 } over (>>orientation)
|
||||
[ (>>margin) ] keep ;
|
||||
{ 1 0 } >>orientation
|
||||
swap >>margin ;
|
||||
|
||||
SYMBOL: x SYMBOL: max-x
|
||||
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ IN: ui.gadgets.scrollers.tests
|
|||
|
||||
<gadget> { 600 400 } >>dim "g1" 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>
|
||||
{ 300 300 } >>dim
|
||||
|
|
|
|||
|
|
@ -33,17 +33,17 @@ scroller H{
|
|||
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
|
||||
|
||||
: new-scroller ( gadget class -- scroller )
|
||||
new-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
new-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
|
||||
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>> first <x-slider> >>x dup x>> @bottom 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 ;
|
||||
|
||||
: scroll ( value scroller -- )
|
||||
|
|
@ -81,7 +81,7 @@ scroller H{
|
|||
: scroll>rect ( rect gadget -- )
|
||||
dup find-scroller* dup [
|
||||
[ relative-scroll-rect ] keep
|
||||
[ (>>follows) ] keep
|
||||
swap >>follows
|
||||
relayout
|
||||
] [
|
||||
3drop
|
||||
|
|
@ -94,7 +94,7 @@ scroller H{
|
|||
|
||||
: scroll>gadget ( gadget -- )
|
||||
dup find-scroller* dup [
|
||||
[ (>>follows) ] keep
|
||||
swap >>follows
|
||||
relayout
|
||||
] [
|
||||
2drop
|
||||
|
|
@ -104,9 +104,7 @@ scroller H{
|
|||
dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
|
||||
|
||||
: scroll>bottom ( gadget -- )
|
||||
find-scroller [
|
||||
t over (>>follows) relayout-1
|
||||
] when* ;
|
||||
find-scroller [ t >>follows relayout-1 ] when* ;
|
||||
|
||||
: scroll>top ( gadget -- )
|
||||
<zero-rect> swap scroll>rect ;
|
||||
|
|
@ -124,14 +122,14 @@ M: f update-scroller drop dup scroller-value swap scroll ;
|
|||
M: scroller layout*
|
||||
dup call-next-method
|
||||
dup follows>>
|
||||
[ update-scroller ] 2keep
|
||||
swap (>>follows) ;
|
||||
2dup update-scroller
|
||||
>>follows drop ;
|
||||
|
||||
M: scroller focusable-child*
|
||||
viewport>> ;
|
||||
|
||||
M: scroller model-changed
|
||||
nip f swap (>>follows) ;
|
||||
nip f >>follows drop ;
|
||||
|
||||
TUPLE: limited-scroller < scroller fixed-dim ;
|
||||
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ M: slider model-changed nip elevator>> relayout-1 ;
|
|||
TUPLE: thumb < gadget ;
|
||||
|
||||
: begin-drag ( thumb -- )
|
||||
find-slider dup slider-value swap (>>saved) ;
|
||||
find-slider dup slider-value >>saved drop ;
|
||||
|
||||
: do-drag ( thumb -- )
|
||||
find-slider drag-loc over orientation>> v.
|
||||
|
|
@ -83,7 +83,7 @@ thumb H{
|
|||
dup direction>> swap find-slider slide-by-page ;
|
||||
|
||||
: elevator-click ( elevator -- )
|
||||
dup compute-direction over (>>direction)
|
||||
dup compute-direction >>direction
|
||||
elevator-hold ;
|
||||
|
||||
elevator H{
|
||||
|
|
@ -123,13 +123,13 @@ M: elevator layout*
|
|||
: <slide-button> ( vector polygon amount -- button )
|
||||
>r gray swap <polygon-gadget> r>
|
||||
[ swap find-slider slide-by-line ] curry <repeat-button>
|
||||
[ (>>orientation) ] keep ;
|
||||
swap >>orientation ;
|
||||
|
||||
: elevator, ( gadget orientation -- gadget )
|
||||
tuck <elevator> >>elevator
|
||||
swap <thumb> >>thumb
|
||||
dup elevator>> over thumb>> add-gadget
|
||||
@center grid-add ;
|
||||
tuck <elevator> >>elevator
|
||||
swap <thumb> >>thumb
|
||||
dup elevator>> over thumb>> add-gadget
|
||||
@center grid-add ;
|
||||
|
||||
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
|
||||
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
|
||||
|
|
@ -143,16 +143,16 @@ M: elevator layout*
|
|||
32 >>line ;
|
||||
|
||||
: <x-slider> ( range -- slider )
|
||||
{ 1 0 } <slider>
|
||||
<left-button> @left grid-add
|
||||
{ 0 1 } elevator,
|
||||
<right-button> @right grid-add ;
|
||||
{ 1 0 } <slider>
|
||||
<left-button> @left grid-add
|
||||
{ 0 1 } elevator,
|
||||
<right-button> @right grid-add ;
|
||||
|
||||
: <y-slider> ( range -- slider )
|
||||
{ 0 1 } <slider>
|
||||
<up-button> @top grid-add
|
||||
{ 1 0 } elevator,
|
||||
<down-button> @bottom grid-add ;
|
||||
{ 0 1 } <slider>
|
||||
<up-button> @top grid-add
|
||||
{ 1 0 } elevator,
|
||||
<down-button> @bottom grid-add ;
|
||||
|
||||
M: slider pref-dim*
|
||||
dup call-next-method
|
||||
|
|
|
|||
|
|
@ -69,12 +69,12 @@ M: value-ref finish-editing
|
|||
} define-command
|
||||
|
||||
: <slot-editor> ( ref -- gadget )
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
dup <toolbar> f track-add
|
||||
<source-editor> >>text
|
||||
dup text>> <scroller> 1 track-add
|
||||
dup revert ;
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
dup <toolbar> f track-add
|
||||
<source-editor> >>text
|
||||
dup text>> <scroller> 1 track-add
|
||||
dup revert ;
|
||||
|
||||
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,14 +3,14 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test
|
|||
IN: ui.gadgets.tracks.tests
|
||||
|
||||
[ { 100 100 } ] [
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 100 110 } ] [
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -9,23 +9,23 @@ IN: ui.gadgets.tracks
|
|||
TUPLE: track < pack sizes ;
|
||||
|
||||
: normalized-sizes ( track -- seq )
|
||||
sizes>> dup sift sum '[ dup [ _ / ] when ] map ;
|
||||
sizes>> dup sift sum '[ dup [ _ / ] when ] map ;
|
||||
|
||||
: init-track ( track -- track )
|
||||
init-gadget
|
||||
V{ } clone >>sizes
|
||||
1 >>fill ;
|
||||
init-gadget
|
||||
V{ } clone >>sizes
|
||||
1 >>fill ;
|
||||
|
||||
: new-track ( orientation class -- track )
|
||||
new
|
||||
init-track
|
||||
swap >>orientation ;
|
||||
new
|
||||
init-track
|
||||
swap >>orientation ;
|
||||
|
||||
: <track> ( orientation -- track ) track new-track ;
|
||||
|
||||
: alloted-dim ( track -- dim )
|
||||
[ children>> ] [ sizes>> ] bi { 0 0 }
|
||||
[ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
|
||||
[ children>> ] [ sizes>> ] bi { 0 0 }
|
||||
[ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
|
||||
|
||||
: 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-2 ( track -- dim )
|
||||
[ children>> pref-dims ] [ normalized-sizes ] bi
|
||||
[ [ v/n ] when* ] 2map
|
||||
max-dim
|
||||
[ >fixnum ] map ;
|
||||
[ children>> pref-dims ] [ normalized-sizes ] bi
|
||||
[ [ v/n ] when* ] 2map
|
||||
max-dim
|
||||
[ >fixnum ] map ;
|
||||
|
||||
M: track pref-dim* ( gadget -- dim )
|
||||
[ track-pref-dims-1 ]
|
||||
[ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
|
||||
[ orientation>> ]
|
||||
tri
|
||||
set-axis ;
|
||||
[ track-pref-dims-1 ]
|
||||
[ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
|
||||
[ orientation>> ]
|
||||
tri
|
||||
set-axis ;
|
||||
|
||||
: track-add ( track gadget constraint -- track )
|
||||
pick sizes>> push add-gadget ;
|
||||
pick sizes>> push add-gadget ;
|
||||
|
||||
: track-remove ( track gadget -- track )
|
||||
dupd dup
|
||||
[
|
||||
[ swap children>> index ]
|
||||
[ unparent sizes>> ] 2bi
|
||||
delete-nth
|
||||
]
|
||||
[ 2drop ]
|
||||
if ;
|
||||
dupd dup [
|
||||
[ swap children>> index ]
|
||||
[ unparent sizes>> ] 2bi
|
||||
delete-nth
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ TUPLE: viewport < gadget ;
|
|||
viewport new-gadget
|
||||
swap >>model
|
||||
t >>clipped?
|
||||
[ swap add-gadget drop ] keep ;
|
||||
swap add-gadget ;
|
||||
|
||||
M: viewport layout*
|
||||
dup rect-dim viewport-gap 2 v*n v-
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ IN: ui.gadgets.worlds.tests
|
|||
|
||||
<gadget> "g1" 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
|
||||
|
|
@ -33,8 +33,8 @@ IN: ui.gadgets.worlds.tests
|
|||
<gadget> "g1" set
|
||||
<gadget> "g2" set
|
||||
<gadget> "g3" set
|
||||
"g1" get "g3" get swap add-gadget drop
|
||||
"g2" get "g3" get swap add-gadget drop
|
||||
"g3" get "g1" get add-gadget drop
|
||||
"g3" get "g2" get add-gadget drop
|
||||
|
||||
[ ] [
|
||||
"g3" get <test-world> "w" set
|
||||
|
|
@ -55,7 +55,7 @@ TUPLE: focus-test < gadget ;
|
|||
|
||||
: <focus-test>
|
||||
focus-test new-gadget
|
||||
<focusing> over swap add-gadget drop ;
|
||||
dup <focusing> add-gadget drop ;
|
||||
|
||||
M: focus-test focusable-child* gadget-child ;
|
||||
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ SYMBOL: ui-error-hook
|
|||
(draw-world)
|
||||
] [
|
||||
over <world-error> ui-error
|
||||
f swap (>>active?)
|
||||
f >>active? drop
|
||||
] recover
|
||||
] with-variable
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -19,8 +19,7 @@ TUPLE: operation predicate command translator hook listener? ;
|
|||
swap >>predicate ;
|
||||
|
||||
PREDICATE: listener-operation < operation
|
||||
dup command>> listener-command?
|
||||
swap listener?>> or ;
|
||||
[ command>> listener-command? ] [ listener?>> ] bi or ;
|
||||
|
||||
M: operation command-name
|
||||
command>> command-name ;
|
||||
|
|
@ -59,15 +58,15 @@ SYMBOL: operations
|
|||
|
||||
: modify-operation ( hook translator operation -- operation )
|
||||
clone
|
||||
tuck (>>translator)
|
||||
tuck (>>hook)
|
||||
t over (>>listener?) ;
|
||||
swap >>translator
|
||||
swap >>hook
|
||||
t >>listener? ;
|
||||
|
||||
: 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 )
|
||||
>r >r object-operations r> r> modify-operations
|
||||
[ object-operations ] 2dip modify-operations
|
||||
[ [ operation-gesture ] keep ] { } map>assoc ;
|
||||
|
||||
: define-operation-map ( class group blurb object hook translator -- )
|
||||
|
|
|
|||
|
|
@ -139,7 +139,7 @@ M: polygon draw-interior
|
|||
: <polygon-gadget> ( color points -- gadget )
|
||||
dup max-dim
|
||||
>r <polygon> <gadget> r> >>dim
|
||||
[ (>>interior) ] keep ;
|
||||
swap >>interior ;
|
||||
|
||||
! Font rendering
|
||||
SYMBOL: font-renderer
|
||||
|
|
|
|||
|
|
@ -20,11 +20,11 @@ TUPLE: browser-gadget < track pane history ;
|
|||
"handbook" >link <history> >>history drop ;
|
||||
|
||||
: <browser-gadget> ( -- gadget )
|
||||
{ 0 1 } browser-gadget new-track
|
||||
dup init-history
|
||||
dup <toolbar> f track-add
|
||||
dup <help-pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
{ 0 1 } browser-gadget new-track
|
||||
dup init-history
|
||||
dup <toolbar> f track-add
|
||||
dup <help-pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
M: browser-gadget call-tool* show-help ;
|
||||
|
||||
|
|
|
|||
|
|
@ -42,8 +42,8 @@ TUPLE: deploy-gadget < pack vocab settings ;
|
|||
deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
|
||||
|
||||
: deploy-settings-theme ( gadget -- gadget )
|
||||
{ 10 10 } >>gap
|
||||
1 >>fill ;
|
||||
{ 10 10 } >>gap
|
||||
1 >>fill ;
|
||||
|
||||
: <deploy-settings> ( vocab -- control )
|
||||
default-config [ <model> ] assoc-map
|
||||
|
|
@ -57,7 +57,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
|
|||
advanced-settings
|
||||
|
||||
deploy-settings-theme
|
||||
namespace <mapping> over (>>model)
|
||||
namespace <mapping> >>model
|
||||
]
|
||||
bind ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,11 +16,11 @@ TUPLE: inspector-gadget < track object pane ;
|
|||
] with-pane ;
|
||||
|
||||
: <inspector-gadget> ( -- gadget )
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
dup <toolbar> f track-add
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
dup <toolbar> f track-add
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
: inspect-object ( obj mirror keys inspector -- )
|
||||
2nip swap >>object refresh ;
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: ui.tools.listener.tests
|
|||
[ "dup" ] [
|
||||
\ dup word-completion-string
|
||||
] unit-test
|
||||
|
||||
|
||||
[ "equal?" ]
|
||||
[ \ array \ equal? method word-completion-string ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -13,8 +13,8 @@ IN: ui.tools.listener
|
|||
TUPLE: listener-gadget < track input output stack ;
|
||||
|
||||
: listener-output, ( listener -- listener )
|
||||
<scrolling-pane> >>output
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
|
||||
<scrolling-pane> >>output
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
|
||||
|
||||
: listener-streams ( listener -- input output )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||
|
|
@ -23,15 +23,15 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
output>> <pane-stream> <interactor> ;
|
||||
|
||||
: listener-input, ( listener -- listener )
|
||||
dup <listener-input> >>input
|
||||
dup input>>
|
||||
{ 0 100 } <limited-scroller>
|
||||
"Input" <labelled-gadget>
|
||||
f track-add ;
|
||||
dup <listener-input> >>input
|
||||
dup input>>
|
||||
{ 0 100 } <limited-scroller>
|
||||
"Input" <labelled-gadget>
|
||||
f track-add ;
|
||||
|
||||
: welcome. ( -- )
|
||||
"If this is your first time with Factor, please read the " print
|
||||
"handbook" ($link) "." print nl ;
|
||||
"If this is your first time with Factor, please read the " print
|
||||
"handbook" ($link) "." print nl ;
|
||||
|
||||
M: listener-gadget focusable-child*
|
||||
input>> ;
|
||||
|
|
@ -121,11 +121,10 @@ M: engine-word word-completion-string
|
|||
TUPLE: stack-display < track ;
|
||||
|
||||
: <stack-display> ( workspace -- gadget )
|
||||
listener>>
|
||||
{ 0 1 } stack-display new-track
|
||||
listener>>
|
||||
{ 0 1 } stack-display new-track
|
||||
over <toolbar> f track-add
|
||||
swap
|
||||
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
|
||||
swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
|
||||
1 track-add ;
|
||||
|
||||
M: stack-display tool-scroller
|
||||
|
|
@ -166,14 +165,14 @@ M: stack-display tool-scroller
|
|||
} cleave ;
|
||||
|
||||
: init-listener ( listener -- )
|
||||
f <model> swap (>>stack) ;
|
||||
f <model> >>stack drop ;
|
||||
|
||||
: <listener-gadget> ( -- gadget )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
dup init-listener
|
||||
listener-output,
|
||||
listener-input, ;
|
||||
|
||||
{ 0 1 } listener-gadget new-track
|
||||
dup init-listener
|
||||
listener-output,
|
||||
listener-input, ;
|
||||
|
||||
: listener-help ( -- ) "ui-listener" help-window ;
|
||||
|
||||
\ listener-help H{ { +nullary+ t } } define-command
|
||||
|
|
|
|||
|
|
@ -8,11 +8,11 @@ IN: ui.tools.profiler
|
|||
TUPLE: profiler-gadget < track pane ;
|
||||
|
||||
: <profiler-gadget> ( -- gadget )
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
dup <toolbar> f track-add
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
dup <toolbar> f track-add
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
: with-profiler-pane ( gadget quot -- )
|
||||
>r pane>> r> with-pane ;
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ IN: ui.tools.search.tests
|
|||
] with-grafted-gadget ;
|
||||
|
||||
: 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 ] [
|
||||
"swp" all-words f <definition-search>
|
||||
|
|
|
|||
|
|
@ -60,15 +60,14 @@ search-field H{
|
|||
swap <list> ;
|
||||
|
||||
: <live-search> ( string seq limited? presenter -- gadget )
|
||||
{ 0 1 } live-search new-track
|
||||
<search-field> >>field
|
||||
dup field>> f track-add
|
||||
-roll <search-list> >>list
|
||||
dup list>> <scroller> 1 track-add
|
||||
|
||||
swap
|
||||
over field>> set-editor-string
|
||||
dup field>> end-of-document ;
|
||||
{ 0 1 } live-search new-track
|
||||
<search-field> >>field
|
||||
dup field>> f track-add
|
||||
-roll <search-list> >>list
|
||||
dup list>> <scroller> 1 track-add
|
||||
swap
|
||||
over field>> set-editor-string
|
||||
dup field>> end-of-document ;
|
||||
|
||||
M: live-search focusable-child* field>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: ui.tools.tests
|
|||
|
||||
[ f ]
|
||||
[
|
||||
<gadget> 0 <model> >>model <workspace-tabs> children>> empty?
|
||||
<gadget> 0 <model> >>model <workspace-tabs> children>> empty?
|
||||
] unit-test
|
||||
|
||||
[ ] [ <workspace> "w" set ] unit-test
|
||||
|
|
|
|||
|
|
@ -13,35 +13,30 @@ mirrors ;
|
|||
IN: ui.tools
|
||||
|
||||
: <workspace-tabs> ( workspace -- tabs )
|
||||
model>>
|
||||
"tool-switching" workspace command-map commands>>
|
||||
[ command-string ] { } assoc>map <enum> >alist
|
||||
<toggle-buttons> ;
|
||||
model>>
|
||||
"tool-switching" workspace command-map commands>>
|
||||
[ command-string ] { } assoc>map <enum> >alist
|
||||
<toggle-buttons> ;
|
||||
|
||||
: <workspace-book> ( workspace -- gadget )
|
||||
|
||||
dup
|
||||
<stack-display>
|
||||
<browser-gadget>
|
||||
<inspector-gadget>
|
||||
<profiler-gadget>
|
||||
4array
|
||||
|
||||
swap model>>
|
||||
|
||||
<book> ;
|
||||
dup
|
||||
<stack-display>
|
||||
<browser-gadget>
|
||||
<inspector-gadget>
|
||||
<profiler-gadget>
|
||||
4array
|
||||
swap model>> <book> ;
|
||||
|
||||
: <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
|
||||
<listener-gadget> >>listener
|
||||
dup <workspace-book> >>book
|
||||
|
||||
dup <workspace-tabs> f track-add
|
||||
dup book>> 1/5 track-add
|
||||
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 -- )
|
||||
dup sizes>> over control-value zero? [
|
||||
|
|
|
|||
|
|
@ -25,14 +25,14 @@ TUPLE: traceback-gadget < track ;
|
|||
M: traceback-gadget pref-dim* drop { 550 600 } ;
|
||||
|
||||
: <traceback-gadget> ( model -- gadget )
|
||||
{ 0 1 } traceback-gadget new-track
|
||||
swap >>model
|
||||
{ 0 1 } traceback-gadget new-track
|
||||
swap >>model
|
||||
|
||||
dup model>>
|
||||
{ 1 0 } <track>
|
||||
over <datastack-display> 1/2 track-add
|
||||
swap <retainstack-display> 1/2 track-add
|
||||
1/3 track-add
|
||||
{ 1 0 } <track>
|
||||
over <datastack-display> 1/2 track-add
|
||||
swap <retainstack-display> 1/2 track-add
|
||||
1/3 track-add
|
||||
|
||||
dup model>> <callstack-display> 2/3 track-add
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ GENERIC: tool-scroller ( tool -- scroller )
|
|||
M: gadget tool-scroller drop f ;
|
||||
|
||||
: find-tool ( class workspace -- index tool )
|
||||
book>> children>> [ class eq? ] with find ;
|
||||
book>> children>> [ class eq? ] with find ;
|
||||
|
||||
: show-tool ( class workspace -- tool )
|
||||
[ find-tool swap ] keep book>> model>>
|
||||
|
|
@ -55,15 +55,15 @@ M: gadget tool-scroller drop f ;
|
|||
article-title open-window ;
|
||||
|
||||
: hide-popup ( workspace -- )
|
||||
dup popup>> track-remove
|
||||
f >>popup
|
||||
request-focus ;
|
||||
dup popup>> track-remove
|
||||
f >>popup
|
||||
request-focus ;
|
||||
|
||||
: show-popup ( gadget workspace -- )
|
||||
dup hide-popup
|
||||
over >>popup
|
||||
over f track-add drop
|
||||
request-focus ;
|
||||
dup hide-popup
|
||||
over >>popup
|
||||
over f track-add drop
|
||||
request-focus ;
|
||||
|
||||
: show-titled-popup ( workspace gadget title -- )
|
||||
[ find-workspace hide-popup ] <closable-gadget>
|
||||
|
|
|
|||
|
|
@ -51,12 +51,12 @@ SYMBOL: stop-after-last-window?
|
|||
T{ gain-focus } swap each-gesture ;
|
||||
|
||||
: focus-world ( world -- )
|
||||
t over (>>focused?)
|
||||
t >>focused?
|
||||
dup raised-window
|
||||
focus-path f focus-gestures ;
|
||||
|
||||
: unfocus-world ( world -- )
|
||||
f over (>>focused?)
|
||||
f >>focused?
|
||||
focus-path f swap focus-gestures ;
|
||||
|
||||
M: world graft*
|
||||
|
|
@ -69,7 +69,7 @@ M: world graft*
|
|||
#! when restoring saved worlds on image startup.
|
||||
dup fonts>> clear-assoc
|
||||
dup unfocus-world
|
||||
f swap (>>handle) ;
|
||||
f >>handle drop ;
|
||||
|
||||
M: world ungraft*
|
||||
dup free-fonts
|
||||
|
|
@ -93,13 +93,8 @@ SYMBOL: ui-hook
|
|||
dup graft-state>> {
|
||||
{ { f f } [ ] }
|
||||
{ { f t } [ ] }
|
||||
{ { t t } [
|
||||
{ f f } over (>>graft-state)
|
||||
] }
|
||||
{ { t f } [
|
||||
dup unqueue-graft
|
||||
{ f f } over (>>graft-state)
|
||||
] }
|
||||
{ { t t } [ { f f } >>graft-state ] }
|
||||
{ { t f } [ dup unqueue-graft { f f } >>graft-state ] }
|
||||
} case graft-later ;
|
||||
|
||||
: restore-gadget ( gadget -- )
|
||||
|
|
@ -172,7 +167,7 @@ SYMBOL: ui-thread
|
|||
"UI update" spawn drop ;
|
||||
|
||||
: open-world-window ( world -- )
|
||||
dup pref-dim over (>>dim) dup relayout graft ;
|
||||
dup pref-dim >>dim dup relayout graft ;
|
||||
|
||||
: open-window ( gadget title -- )
|
||||
f <world> open-world-window ;
|
||||
|
|
|
|||
|
|
@ -21,8 +21,8 @@ C: <x11-handle> x11-handle
|
|||
M: world expose-event nip relayout ;
|
||||
|
||||
M: world configure-event
|
||||
over configured-loc over (>>window-loc)
|
||||
swap configured-dim over (>>dim)
|
||||
over configured-loc >>window-loc
|
||||
swap configured-dim >>dim
|
||||
! In case dimensions didn't change
|
||||
relayout-1 ;
|
||||
|
||||
|
|
@ -173,7 +173,7 @@ M: world client-event
|
|||
dup window-loc>> over rect-dim glx-window
|
||||
over "Factor" create-xic <x11-handle>
|
||||
2dup window>> register-window
|
||||
swap (>>handle) ;
|
||||
>>handle drop ;
|
||||
|
||||
: wait-event ( -- event )
|
||||
QueuedAfterFlush events-queued 0 > [
|
||||
|
|
|
|||
|
|
@ -98,5 +98,4 @@ VALUE: grapheme-table
|
|||
|
||||
init-grapheme-table table
|
||||
[ make-grapheme-table finish-table ] with-variable
|
||||
\ grapheme-table set-value
|
||||
|
||||
to: grapheme-table
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ TUPLE: weight primary secondary tertiary ignorable? ;
|
|||
[ parse-line ] H{ } map>assoc ;
|
||||
|
||||
"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
|
||||
: help-one ( assoc key -- )
|
||||
|
|
|
|||
|
|
@ -164,18 +164,16 @@ C: <code-point> code-point
|
|||
[ [ set-code-point ] each ] H{ } make-assoc ;
|
||||
|
||||
load-data {
|
||||
[ process-names \ name-map set-value ]
|
||||
[ 13 swap process-data \ simple-lower set-value ]
|
||||
[ 12 swap process-data \ simple-upper set-value ]
|
||||
[ 14 swap process-data
|
||||
simple-upper assoc-union \ simple-title set-value ]
|
||||
[ process-combining \ class-map set-value ]
|
||||
[ process-canonical \ canonical-map set-value
|
||||
\ combine-map set-value ]
|
||||
[ process-compatibility \ compatibility-map set-value ]
|
||||
[ process-category \ category-map set-value ]
|
||||
[ process-names to: name-map ]
|
||||
[ 13 swap process-data to: simple-lower ]
|
||||
[ 12 swap process-data to: simple-upper ]
|
||||
[ 14 swap process-data simple-upper assoc-union to: simple-title ]
|
||||
[ process-combining to: class-map ]
|
||||
[ process-canonical to: canonical-map to: combine-map ]
|
||||
[ process-compatibility to: compatibility-map ]
|
||||
[ process-category to: category-map ]
|
||||
} cleave
|
||||
|
||||
load-special-casing \ special-casing set-value
|
||||
load-special-casing to: special-casing
|
||||
|
||||
load-properties \ properties set-value
|
||||
load-properties to: properties
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ SYMBOL: interned
|
|||
|
||||
: process-script ( ranges -- )
|
||||
dup values prune >symbols interned [
|
||||
expand-ranges \ script-table set-value
|
||||
expand-ranges to: script-table
|
||||
] with-variable ;
|
||||
|
||||
: load-script ( -- )
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ ARTICLE: "values" "Global values"
|
|||
"To get the value, just call the word. The following words manipulate values:"
|
||||
{ $subsection get-value }
|
||||
{ $subsection set-value }
|
||||
{ $subsection POSTPONE: to: }
|
||||
{ $subsection change-value } ;
|
||||
|
||||
HELP: VALUE:
|
||||
|
|
@ -20,8 +21,19 @@ HELP: get-value
|
|||
|
||||
HELP: set-value
|
||||
{ $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
|
||||
{ $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." } ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ IN: values.tests
|
|||
|
||||
VALUE: foo
|
||||
[ f ] [ foo ] unit-test
|
||||
[ ] [ 3 \ foo set-value ] unit-test
|
||||
[ ] [ 3 to: foo ] unit-test
|
||||
[ 3 ] [ foo ] unit-test
|
||||
[ ] [ \ foo [ 1+ ] change-value ] unit-test
|
||||
[ 4 ] [ foo ] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
! 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:
|
||||
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
|
||||
|
||||
: set-value ( value word -- )
|
||||
def>> first set-first ;
|
||||
def>> first (>>obj) ;
|
||||
|
||||
: to:
|
||||
scan-word literalize parsed
|
||||
\ set-value parsed ; parsing
|
||||
|
||||
: get-value ( word -- value )
|
||||
def>> first first ;
|
||||
def>> first obj>> ;
|
||||
|
||||
: change-value ( word quot -- )
|
||||
over >r >r get-value r> call r> set-value ; inline
|
||||
[ [ get-value ] dip call ] [ drop ] 2bi set-value ; inline
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math.private namespaces make sequences strings
|
||||
arrays combinators splitting math assocs ;
|
||||
USING: kernel math.private namespaces sequences strings
|
||||
arrays combinators splitting math assocs make ;
|
||||
IN: math.parser
|
||||
|
||||
: digit> ( ch -- n )
|
||||
|
|
@ -94,10 +94,10 @@ PRIVATE>
|
|||
: >digit ( n -- ch )
|
||||
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
|
||||
|
||||
: integer, ( num radix -- )
|
||||
: positive>base ( num radix -- str )
|
||||
dup 1 <= [ "Invalid radix" throw ] when
|
||||
[ /mod >digit , ] keep over 0 >
|
||||
[ integer, ] [ 2drop ] if ;
|
||||
[ dup 0 > ] swap [ /mod >digit ] curry [ ] "" produce-as nip
|
||||
dup reverse-here ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -110,24 +110,27 @@ GENERIC# >base 1 ( n radix -- str )
|
|||
PRIVATE>
|
||||
|
||||
M: integer >base
|
||||
[
|
||||
over 0 < [
|
||||
swap neg swap integer, CHAR: - ,
|
||||
over 0 = [
|
||||
2drop "0"
|
||||
] [
|
||||
over 0 > [
|
||||
positive>base
|
||||
] [
|
||||
integer,
|
||||
[ neg ] dip positive>base CHAR: - prefix
|
||||
] if
|
||||
] "" make reverse ;
|
||||
] if ;
|
||||
|
||||
M: ratio >base
|
||||
[
|
||||
dup 0 < negative? set
|
||||
1 /mod
|
||||
[ dup zero? [ drop "" ] [ (>base) sign append ] if ]
|
||||
[
|
||||
dup 0 < dup negative? set [ "-" % neg ] when
|
||||
1 /mod
|
||||
>r dup zero? [ drop ] [ (>base) % sign % ] if r>
|
||||
dup numerator (>base) %
|
||||
"/" %
|
||||
denominator (>base) %
|
||||
] "" make
|
||||
[ numerator (>base) ]
|
||||
[ denominator (>base) ] bi
|
||||
"/" swap 3append
|
||||
] bi* append
|
||||
negative? get [ CHAR: - prefix ] when
|
||||
] with-radix ;
|
||||
|
||||
: fix-float ( str -- newstr )
|
||||
|
|
|
|||
|
|
@ -454,8 +454,11 @@ PRIVATE>
|
|||
: accumulator ( quot -- quot' vec )
|
||||
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 )
|
||||
swap accumulator >r swap while r> { } like ; inline
|
||||
{ } produce-as ; inline
|
||||
|
||||
: follow ( obj quot -- seq )
|
||||
>r [ dup ] r> [ keep ] curry [ ] produce nip ; inline
|
||||
|
|
|
|||
Loading…
Reference in New Issue