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

db4
John Benediktsson 2008-12-19 08:45:02 -08:00
commit 3c4f26ebd9
18 changed files with 97 additions and 33 deletions

View File

@ -3,3 +3,4 @@ USING: tools.test help kernel ;
[ 3 throw ] must-fail [ 3 throw ] must-fail
[ ] [ :help ] unit-test [ ] [ :help ] unit-test
[ ] [ f print-topic ] unit-test

View File

@ -112,6 +112,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
] with-style nl ; ] with-style nl ;
: print-topic ( topic -- ) : print-topic ( topic -- )
>link
last-element off dup $title last-element off dup $title
article-content print-content nl ; article-content print-content nl ;

View File

@ -58,6 +58,8 @@ IN: http.server.cgi
] with-stream ] with-stream
] >>body ; ] >>body ;
SLOT: special
: enable-cgi ( responder -- responder ) : enable-cgi ( responder -- responder )
[ serve-cgi ] "application/x-cgi-script" [ serve-cgi ] "application/x-cgi-script"
pick special>> set-at ; pick special>> set-at ;

View File

@ -1,5 +1,6 @@
USING: io.directories io.files.links tools.test USING: io.directories io.files.links tools.test sequences
io.files.unique tools.files fry ; io.files.unique tools.files fry math kernel math.parser
io.pathnames namespaces ;
IN: io.files.links.tests IN: io.files.links.tests
: make-test-links ( n path -- ) : make-test-links ( n path -- )

View File

@ -1,5 +1,5 @@
USING: arrays generic kernel math models namespaces sequences assocs USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.compose accessors ; tools.test models.compose accessors locals ;
IN: models.compose.tests IN: models.compose.tests
! Test compose ! Test compose
@ -22,3 +22,25 @@ IN: models.compose.tests
[ { 4 5 } ] [ "c" get value>> ] unit-test [ { 4 5 } ] [ "c" get value>> ] unit-test
[ ] [ "c" get deactivate-model ] unit-test [ ] [ "c" get deactivate-model ] unit-test
TUPLE: an-observer { i integer } ;
M: an-observer model-changed nip [ 1+ ] change-i drop ;
[ 1 0 ] [
[let* | m1 [ 1 <model> ]
m2 [ 2 <model> ]
c [ { m1 m2 } <compose> ]
o1 [ an-observer new ]
o2 [ an-observer new ] |
o1 m1 add-connection
o2 m2 add-connection
c activate-model
"OH HAI" m1 set-model
o1 i>>
o2 i>>
]
] unit-test

View File

@ -18,7 +18,8 @@ TUPLE: compose < model ;
M: compose model-changed M: compose model-changed
nip nip
[ [ value>> ] composed-value ] keep set-model ; dup [ value>> ] composed-value >>value
notify-connections ;
M: compose model-activated dup model-changed ; M: compose model-activated dup model-changed ;

View File

@ -1,6 +1,7 @@
IN: struct-arrays.tests IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences USING: struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors ; alien.syntax alien.c-types destructors libc accessors
destructors ;
C-STRUCT: test-struct C-STRUCT: test-struct
{ "int" "x" } { "int" "x" }
@ -27,3 +28,12 @@ C-STRUCT: test-struct
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
] with-destructors ] with-destructors
] unit-test ] unit-test
[ ] [ ALIEN: 123 10 "test-struct" <direct-struct-array> drop ] unit-test
[ ] [
[
10 "test-struct" malloc-struct-array
underlying>> &free drop
] with-destructors
] unit-test

View File

@ -32,9 +32,9 @@ ERROR: bad-byte-array-length byte-array ;
] keep struct-array boa ; inline ] keep struct-array boa ; inline
: <direct-struct-array> ( alien length c-type -- struct-array ) : <direct-struct-array> ( alien length c-type -- struct-array )
struct-array boa ; inline heap-size struct-array boa ; inline
: malloc-struct-array ( length c-type -- struct-array ) : malloc-struct-array ( length c-type -- struct-array )
heap-size [ calloc ] 2keep <direct-struct-array> ; [ heap-size calloc ] 2keep <direct-struct-array> ;
INSTANCE: struct-array sequence INSTANCE: struct-array sequence

View File

@ -16,6 +16,9 @@ TUPLE: border < gadget
swap border new-border swap border new-border
swap dup 2array >>size ; swap dup 2array >>size ;
: <filled-border> ( child gap -- border )
<border> { 1 1 } >>fill ;
M: border pref-dim* M: border pref-dim*
[ size>> 2 v*n ] keep [ size>> 2 v*n ] keep
gadget-child pref-dim v+ ; gadget-child pref-dim v+ ;

View File

@ -107,7 +107,7 @@ M: editor ungraft*
editor-font* "" string-height ; editor-font* "" string-height ;
: y>line ( y editor -- line# ) : y>line ( y editor -- line# )
line-height / >fixnum ; line-height /i ;
:: point>loc ( point editor -- loc ) :: point>loc ( point editor -- loc )
point second editor y>line { point second editor y>line {

View File

@ -1,6 +1,6 @@
! 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: locals accessors arrays ui.commands ui.gadgets USING: locals accessors arrays ui.commands ui.operations ui.gadgets
ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic
hashtables kernel math models namespaces opengl sequences hashtables kernel math models namespaces opengl sequences
math.vectors ui.gadgets.theme ui.gadgets.packs math.vectors ui.gadgets.theme ui.gadgets.packs
@ -54,3 +54,9 @@ M: menu-glass layout* gadget-child prefer ;
: show-commands-menu ( target commands -- ) : show-commands-menu ( target commands -- )
[ dup [ ] ] dip <commands-menu> show-menu ; [ dup [ ] ] dip <commands-menu> show-menu ;
: <operations-menu> ( target hook -- menu )
over object-operations <commands-menu> ;
: show-operations-menu ( gadget target -- )
[ ] <operations-menu> show-menu ;

View File

@ -35,8 +35,6 @@ HELP: <presentation>
{ <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words { <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words
{ <commands-menu> <toolbar> operations-menu show-menu } related-words
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words { <status-bar> show-mouse-help show-status show-summary hide-status } related-words
HELP: show-mouse-help HELP: show-mouse-help

View File

@ -11,8 +11,8 @@ IN: ui.gadgets.presentations
TUPLE: presentation < button object hook ; TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- ) : invoke-presentation ( presentation command -- )
over dup hook>> call [ [ dup hook>> call ] [ object>> ] bi ] dip
[ object>> ] dip invoke-command ; invoke-command ;
: invoke-primary ( presentation -- ) : invoke-primary ( presentation -- )
dup object>> primary-operation dup object>> primary-operation
@ -23,7 +23,7 @@ TUPLE: presentation < button object hook ;
invoke-presentation ; invoke-presentation ;
: show-mouse-help ( presentation -- ) : show-mouse-help ( presentation -- )
dup object>> over show-summary button-update ; [ [ object>> ] keep show-summary ] [ button-update ] bi ;
: <presentation> ( label object -- button ) : <presentation> ( label object -- button )
swap [ invoke-primary ] presentation new-button swap [ invoke-primary ] presentation new-button
@ -35,18 +35,13 @@ M: presentation ungraft*
dup hand-gadget get-global child? [ dup hide-status ] when dup hand-gadget get-global child? [ dup hide-status ] when
call-next-method ; call-next-method ;
: <operations-menu> ( presentation -- menu ) : show-operations-menu ( presentation -- )
[ object>> ] [ ] [ object>> ] [ dup hook>> curry ] tri
[ dup hook>> curry ] <operations-menu> show-menu ;
[ object>> object-operations ]
tri <commands-menu> ;
: operations-menu ( presentation -- )
dup <operations-menu> show-menu ;
presentation H{ presentation H{
{ T{ button-down f f 3 } [ operations-menu ] } { T{ button-down f f 3 } [ show-operations-menu ] }
{ T{ mouse-leave } [ dup hide-status button-update ] } { T{ mouse-leave } [ [ hide-status ] [ button-update ] bi ] }
{ T{ mouse-enter } [ show-mouse-help ] } { T{ mouse-enter } [ show-mouse-help ] }
! Responding to motion too allows nested presentations to ! Responding to motion too allows nested presentations to
! display status help properly, when the mouse leaves a ! display status help properly, when the mouse leaves a

View File

@ -21,3 +21,20 @@ IN: ui.gadgets.tracks.tests
<gadget> { 10 10 } >>dim 0 track-add <gadget> { 10 10 } >>dim 0 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 10 30 } ] [
{ 0 1 } <track>
<gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add
pref-dim
] unit-test
[ { 10 40 } ] [
{ 0 1 } <track>
{ 5 5 } >>gap
<gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add
pref-dim
] unit-test

View File

@ -27,10 +27,15 @@ TUPLE: track < pack sizes ;
[ 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- ; : gap-dim ( track -- dim )
[ gap>> ] [ children>> length 1 [-] ] bi v*n ;
: available-dim ( track -- dim )
[ dim>> ] [ alloted-dim ] bi v- ;
: track-layout ( track -- sizes ) : track-layout ( track -- sizes )
[ available-dim ] [ children>> ] [ normalized-sizes ] tri [ [ available-dim ] [ gap-dim ] bi v- ]
[ children>> ] [ normalized-sizes ] tri
[ [ over n*v ] [ pref-dim ] ?if ] 2map nip ; [ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
M: track layout* ( track -- ) dup track-layout pack-layout ; M: track layout* ( track -- ) dup track-layout pack-layout ;
@ -41,11 +46,9 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
: track-pref-dims-2 ( track -- dim ) : track-pref-dims-2 ( track -- dim )
[ [
[ children>> pref-dims ] [ normalized-sizes ] bi [ children>> pref-dims ] [ normalized-sizes ] bi
[ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map [ dup { 0 f } member? [ 2drop { 0 0 } ] [ v/n ] if ] 2map
max-dim [ >fixnum ] map max-dim [ >fixnum ] map
] ] [ gap-dim ] bi v+ ;
[ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
v+ ;
M: track pref-dim* ( gadget -- dim ) M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ] [ track-pref-dims-1 ]

View File

@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
ui.tools.search ui.tools.workspace kernel models namespaces ui.tools.search ui.tools.workspace kernel models namespaces
sequences tools.test ui.gadgets ui.gadgets.buttons sequences tools.test ui.gadgets ui.gadgets.buttons
ui.gadgets.labelled ui.gadgets.presentations ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs tools.test.ui ui accessors ; ui.gadgets.menus ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
IN: ui.tools.tests IN: ui.tools.tests
[ f ] [ f ]
@ -40,7 +40,10 @@ IN: ui.tools.tests
[ t ] [ "p" get presentation? ] unit-test [ t ] [ "p" get presentation? ] unit-test
[ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test [ ] [
"p" get [ object>> ] [ dup hook>> curry ] bi
<operations-menu> gadget-child gadget-child "c" set
] unit-test
[ ] [ notify-queued ] unit-test [ ] [ notify-queued ] unit-test

View File

@ -61,3 +61,4 @@ SYMBOL: xml-file
[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk second ] unit-test [ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk second ] unit-test
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk second ] unit-test [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk second ] unit-test
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk second ] unit-test [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk second ] unit-test
[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk [ write-xml-chunk ] with-string-writer = ] unit-test

View File

@ -112,7 +112,7 @@ M: system-id write-xml-chunk
M: public-id write-xml-chunk M: public-id write-xml-chunk
"PUBLIC '" write "PUBLIC '" write
[ pubid-literal>> write "' '" write ] [ pubid-literal>> write "' '" write ]
[ system-literal>> write "'>" write ] bi ; [ system-literal>> write "'" write ] bi ;
M: doctype-decl write-xml-chunk M: doctype-decl write-xml-chunk
"<!DOCTYPE " write "<!DOCTYPE " write