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

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

db4
Joe Groff 2009-10-05 17:56:43 -05:00
parent fbe810fc3b 317c3f82d5
commit b1d52517c5
14 changed files with 138 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/io/backend/windows/nt/nt.factor
View File

@ -91,6 +91,8 @@ ERROR: seek-before-start n ;
: set-seek-ptr ( n handle -- ) : set-seek-ptr ( n handle -- )
[ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ; [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
M: winnt tell-handle ( handle -- n ) ptr>> ;
M: winnt seek-handle ( n seek-type handle -- ) M: winnt seek-handle ( n seek-type handle -- )
swap { swap {
{ seek-absolute [ set-seek-ptr ] } { seek-absolute [ set-seek-ptr ] }

7
basis/ui/backend/x11/x11.factor
View File

@ -7,7 +7,8 @@ namespaces sequences strings ui ui.backend ui.clipboards
ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
ui.gestures ui.pixel-formats ui.pixel-formats.private ui.gestures ui.pixel-formats ui.pixel-formats.private
ui.private x11 x11.clipboard x11.constants x11.events x11.glx ui.private x11 x11.clipboard x11.constants x11.events x11.glx
x11.io x11.windows x11.xim x11.xlib environment command-line ; x11.io x11.windows x11.xim x11.xlib environment command-line
combinators.short-circuit ;
IN: ui.backend.x11 IN: ui.backend.x11
SINGLETON: x11-ui-backend SINGLETON: x11-ui-backend
@ -107,9 +108,9 @@ CONSTANT: key-codes
: valid-input? ( string gesture -- ? ) : valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [ over empty? [ 2drop f ] [
mods>> { f { S+ } } member? [ mods>> { f { S+ } } member? [
[ [ 127 = not ] [ CHAR: \s >= ] bi and ] all? [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
] [ ] [
[ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all? [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
] if ] if
] if ; ] if ;

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

@ -1,12 +1,13 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences USING: accessors arrays assocs classes classes.tuple colors
strings quotations assocs combinators classes colors colors.constants colors.constants combinators combinators.short-circuit
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets combinators.smart fry kernel locals math math.rectangles
ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks math.vectors models namespaces opengl opengl.gl quotations
ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid sequences strings ui.commands ui.gadgets ui.gadgets.borders
ui.pens.image ui.pens.tile math.rectangles locals fry ui.gadgets.labels ui.gadgets.packs ui.gadgets.tracks
combinators.smart ; ui.gadgets.worlds ui.gestures ui.pens ui.pens.image
ui.pens.solid ui.pens.tile ;
FROM: models => change-model ; FROM: models => change-model ;
IN: ui.gadgets.buttons IN: ui.gadgets.buttons
@ -30,7 +31,7 @@ PRIVATE>
: button-update ( button -- ) : button-update ( button -- )
dup dup
[ mouse-clicked? ] [ button-rollover? ] bi and { [ mouse-clicked? ] [ button-rollover? ] } 1&&
buttons-down? and buttons-down? and
>>pressed? >>pressed?
relayout-1 ; relayout-1 ;
@ -42,8 +43,9 @@ PRIVATE>
dup "" swap show-status button-update ; dup "" swap show-status button-update ;
: button-clicked ( button -- ) : button-clicked ( button -- )
dup button-update [ ]
dup button-rollover? [ button-update ]
[ button-rollover? ] tri
[ dup quot>> call( button -- ) ] [ drop ] if ; [ dup quot>> call( button -- ) ] [ drop ] if ;
button H{ button H{
@ -67,7 +69,9 @@ C: <button-pen> button-pen
: button-pen ( button pen -- button pen ) : button-pen ( button pen -- button pen )
over find-button { over find-button {
{ [ dup [ pressed?>> ] [ selected?>> ] bi and ] [ drop pressed-selected>> ] } { [ dup { [ pressed?>> ] [ selected?>> ] } 1&& ]
[ drop pressed-selected>>
] }
{ [ dup pressed?>> ] [ drop pressed>> ] } { [ dup pressed?>> ] [ drop pressed>> ] }
{ [ dup selected?>> ] [ drop selected>> ] } { [ dup selected?>> ] [ drop selected>> ] }
{ [ dup button-rollover? ] [ drop rollover>> ] } { [ dup button-rollover? ] [ drop rollover>> ] }

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

@ -1,14 +1,14 @@
! Copyright (C) 2006, 2009 Slava Pestov ! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents documents.elements kernel math USING: accessors alarms arrays assocs calendar colors.constants
math.ranges models models.arrow namespaces locals fry make opengl combinators combinators.short-circuit documents
opengl.gl sequences strings math.vectors math.functions sorting colors documents.elements fry grouping kernel locals make math
colors.constants combinators assocs math.order calendar alarms math.functions math.order math.ranges math.rectangles
continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders math.vectors models models.arrow namespaces opengl sequences
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers sorting splitting ui.baseline-alignment ui.clipboards
ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment ui.gadgets.line-support ui.gadgets.menus ui.gadgets.scrollers
math.rectangles splitting unicode.categories grouping ; ui.gestures ui.pens.solid ui.render ui.text unicode.categories ;
EXCLUDE: fonts => selection ; EXCLUDE: fonts => selection ;
IN: ui.gadgets.editors IN: ui.gadgets.editors
@ -37,14 +37,14 @@ focused? blink blink-alarm ;
editor new-editor ; editor new-editor ;
: activate-editor-model ( editor model -- ) : activate-editor-model ( editor model -- )
2dup add-connection [ add-connection ]
dup activate-model [ nip activate-model ]
swap model>> add-loc ; [ swap model>> add-loc ] 2tri ;
: deactivate-editor-model ( editor model -- ) : deactivate-editor-model ( editor model -- )
2dup remove-connection [ remove-connection ]
dup deactivate-model [ nip deactivate-model ]
swap model>> remove-loc ; [ swap model>> remove-loc ] 2tri ;
: blink-caret ( editor -- ) : blink-caret ( editor -- )
[ not ] change-blink relayout-1 ; [ not ] change-blink relayout-1 ;
@ -71,23 +71,20 @@ SYMBOL: blink-interval
] [ drop ] if ; ] [ drop ] if ;
M: editor graft* M: editor graft*
dup [ dup caret>> activate-editor-model ]
dup caret>> activate-editor-model [ dup mark>> activate-editor-model ] bi ;
dup mark>> activate-editor-model ;
M: editor ungraft* M: editor ungraft*
dup [ stop-blinking ]
dup stop-blinking [ dup caret>> deactivate-editor-model ]
dup caret>> deactivate-editor-model [ dup mark>> deactivate-editor-model ] tri ;
dup mark>> deactivate-editor-model ;
: editor-caret ( editor -- loc ) caret>> value>> ; : editor-caret ( editor -- loc ) caret>> value>> ;
: editor-mark ( editor -- loc ) mark>> value>> ; : editor-mark ( editor -- loc ) mark>> value>> ;
: set-caret ( loc editor -- ) : set-caret ( loc editor -- )
[ model>> validate-loc ] keep [ model>> validate-loc ] [ caret>> ] bi set-model ;
caret>> set-model ;
: change-caret ( editor quot -- ) : change-caret ( editor quot -- )
[ [ [ editor-caret ] [ model>> ] bi ] dip call ] [ drop ] 2bi [ [ [ editor-caret ] [ model>> ] bi ] dip call ] [ drop ] 2bi
@ -115,7 +112,7 @@ M: editor ungraft*
} cond ; } cond ;
: clicked-loc ( editor -- loc ) : clicked-loc ( editor -- loc )
[ hand-rel ] keep point>loc ; [ hand-rel ] [ point>loc ] bi ;
: click-loc ( editor model -- ) : click-loc ( editor model -- )
[ clicked-loc ] dip set-model ; [ clicked-loc ] dip set-model ;
@ -133,20 +130,20 @@ M: editor ungraft*
[ loc>x ] [ [ first ] dip line>y ceiling ] 2bi 2array ; [ loc>x ] [ [ first ] dip line>y ceiling ] 2bi 2array ;
: caret-loc ( editor -- loc ) : caret-loc ( editor -- loc )
[ editor-caret ] keep loc>point ; [ editor-caret ] [ loc>point ] bi ;
: caret-dim ( editor -- dim ) : caret-dim ( editor -- dim )
line-height 0 swap 2array ; [ 0 ] dip line-height 2array ;
: scroll>caret ( editor -- ) : scroll>caret ( editor -- )
dup graft-state>> second [ dup graft-state>> second [
[ [
[ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect> [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
] keep scroll>rect ] [ scroll>rect ] bi
] [ drop ] if ; ] [ drop ] if ;
: draw-caret? ( editor -- ? ) : draw-caret? ( editor -- ? )
[ focused?>> ] [ blink>> ] bi and ; { [ focused?>> ] [ blink>> ] } 1&& ;
: draw-caret ( editor -- ) : draw-caret ( editor -- )
dup draw-caret? [ dup draw-caret? [
@ -166,8 +163,9 @@ TUPLE: selected-line start end first? last? ;
: compute-selection ( editor -- assoc ) : compute-selection ( editor -- assoc )
dup gadget-selection? [ dup gadget-selection? [
[ selection-start/end [ [ first ] bi@ [a,b] ] 2keep ] keep model>> [ selection-start/end [ [ first ] bi@ [a,b] ] [ ] 2bi ]
'[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc [ model>> ] bi
'[ [ _ _ ] [ _ start/end-on-line ] bi 2array ] H{ } map>assoc
] [ drop f ] if ; ] [ drop f ] if ;
:: draw-selection ( line pair editor -- ) :: draw-selection ( line pair editor -- )
@ -186,8 +184,8 @@ TUPLE: selected-line start end first? last? ;
] [ ] [
[ draw-selection ] [ draw-selection ]
[ [
[ [ first2 ] [ selection-color>> ] bi* <selection> ] keep [ [ first2 ] [ selection-color>> ] bi* <selection> ]
draw-unselected-line [ draw-unselected-line ] bi
] 3bi ] 3bi
] if ; ] if ;
@ -209,32 +207,31 @@ M: editor baseline font>> font-metrics ascent>> ;
M: editor cap-height font>> font-metrics cap-height>> ; M: editor cap-height font>> font-metrics cap-height>> ;
: contents-changed ( model editor -- ) : contents-changed ( model editor -- )
swap [ [ nip caret>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
over caret>> [ over validate-loc ] (change-model) [ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
over mark>> [ over validate-loc ] (change-model) [ nip relayout ] 2tri ;
drop relayout ;
: caret/mark-changed ( model editor -- ) : caret/mark-changed ( editor -- )
nip [ restart-blinking ] [ scroll>caret ] bi ; [ restart-blinking ] [ scroll>caret ] bi ;
M: editor model-changed M: editor model-changed
{ {
{ [ 2dup model>> eq? ] [ contents-changed ] } { [ 2dup model>> eq? ] [ contents-changed ] }
{ [ 2dup caret>> eq? ] [ caret/mark-changed ] } { [ 2dup caret>> eq? ] [ nip caret/mark-changed ] }
{ [ 2dup mark>> eq? ] [ caret/mark-changed ] } { [ 2dup mark>> eq? ] [ nip caret/mark-changed ] }
} cond ; } cond ;
M: editor gadget-selection? M: editor gadget-selection?
selection-start/end = not ; selection-start/end = not ;
M: editor gadget-selection M: editor gadget-selection
[ selection-start/end ] keep model>> doc-range ; [ selection-start/end ] [ model>> ] bi doc-range ;
: remove-selection ( editor -- ) : remove-selection ( editor -- )
[ selection-start/end ] keep model>> remove-doc-range ; [ selection-start/end ] [ model>> ] bi remove-doc-range ;
M: editor user-input* M: editor user-input*
[ selection-start/end ] keep model>> set-doc-range t ; [ selection-start/end ] [ model>> ] bi set-doc-range t ;
: editor-string ( editor -- string ) : editor-string ( editor -- string )
model>> doc-string ; model>> doc-string ;
@ -245,9 +242,9 @@ M: editor user-input*
M: editor gadget-text* editor-string % ; M: editor gadget-text* editor-string % ;
: extend-selection ( editor -- ) : extend-selection ( editor -- )
dup request-focus [ request-focus ]
dup restart-blinking [ restart-blinking ]
dup caret>> click-loc ; [ dup caret>> click-loc ] tri ;
: mouse-elt ( -- element ) : mouse-elt ( -- element )
hand-click# get { hand-click# get {
@ -260,24 +257,25 @@ M: editor gadget-text* editor-string % ;
: drag-selection-caret ( loc editor element -- loc ) : drag-selection-caret ( loc editor element -- loc )
[ [
[ drag-direction? ] 2keep model>> [ drag-direction? ] [ model>> ] 2bi
] dip prev/next-elt ? ; ] dip prev/next-elt ? ;
: drag-selection-mark ( loc editor element -- loc ) : drag-selection-mark ( loc editor element -- loc )
[ [
[ drag-direction? not ] keep [ drag-direction? not ]
[ editor-mark ] [ model>> ] bi [ editor-mark ]
[ model>> ] tri
] dip prev/next-elt ? ; ] dip prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark ) : drag-caret&mark ( editor -- caret mark )
dup clicked-loc swap mouse-elt [ clicked-loc ] [ mouse-elt ] bi
[ drag-selection-caret ] 3keep [ drag-selection-caret ]
drag-selection-mark ; [ drag-selection-mark ] 3bi ;
: drag-selection ( editor -- ) : drag-selection ( editor -- )
dup drag-caret&mark [ drag-caret&mark ]
pick mark>> set-model [ mark>> set-model ]
swap caret>> set-model ; [ caret>> set-model ] tri ;
: editor-cut ( editor clipboard -- ) : editor-cut ( editor clipboard -- )
[ gadget-copy ] [ drop remove-selection ] 2bi ; [ gadget-copy ] [ drop remove-selection ] 2bi ;
@ -343,11 +341,9 @@ M: editor gadget-text* editor-string % ;
: delete-to-end-of-line ( editor -- ) : delete-to-end-of-line ( editor -- )
one-line-elt editor-backspace ; one-line-elt editor-backspace ;
: com-undo ( editor -- ) : com-undo ( editor -- ) model>> undo ;
model>> undo ;
: com-redo ( editor -- ) : com-redo ( editor -- ) model>> redo ;
model>> redo ;
editor "editing" f { editor "editing" f {
{ undo-action com-undo } { undo-action com-undo }
@ -515,7 +511,7 @@ PRIVATE>
"\n" swap user-input* drop ; "\n" swap user-input* drop ;
: change-selection ( editor quot -- ) : change-selection ( editor quot -- )
'[ gadget-selection @ ] keep user-input* drop ; inline '[ gadget-selection @ ] [ user-input* drop ] bi ; inline
: join-lines ( string -- string' ) : join-lines ( string -- string' )
"\n" split "\n" split
@ -526,7 +522,7 @@ PRIVATE>
: this-line-and-next ( document line -- start end ) : this-line-and-next ( document line -- start end )
[ nip 0 swap 2array ] [ nip 0 swap 2array ]
[ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ] [ 1 + [ nip ] [ swap doc-line length ] 2bi 2array ]
2bi ; 2bi ;
: last-line? ( document line -- ? ) : last-line? ( document line -- ? )
@ -589,15 +585,16 @@ TUPLE: field < border editor min-cols max-cols ;
M: field font>> editor>> font>> ; M: field font>> editor>> font>> ;
M: field pref-dim* M: field pref-dim*
dup [ ]
[ editor>> pref-dim ] keep [ editor>> pref-dim ]
[ line-gadget-width ] [ drop second ] 2bi 2array [ [ line-gadget-width ] [ drop second ] 2bi 2array ]
border-pref-dim ; tri border-pref-dim ;
TUPLE: model-field < field field-model ; TUPLE: model-field < field field-model ;
: <model-field> ( model -- gadget ) : <model-field> ( model -- gadget )
model-field new-field swap >>field-model ; model-field new-field
swap >>field-model ;
M: model-field graft* M: model-field graft*
[ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ] [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
@ -613,7 +610,8 @@ M: model-field model-changed
TUPLE: action-field < field quot ; TUPLE: action-field < field quot ;
: <action-field> ( quot -- gadget ) : <action-field> ( quot -- gadget )
action-field new-field swap >>quot ; action-field new-field
swap >>quot ;
: invoke-action-field ( field -- ) : invoke-action-field ( field -- )
[ editor>> editor-string ] [ editor>> editor-string ]

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

@ -26,7 +26,8 @@ M: glue pref-dim* drop { 0 0 } ;
length 1 + * [-] ; inline length 1 + * [-] ; inline
: -center) ( pref-dim gap filled-cell dims -- ) : -center) ( pref-dim gap filled-cell dims -- )
[ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline [ nip available-space ]
[ [ remove-nth sum [-] ] [ set-nth ] 2bi ] 2bi ; inline
: (fill-center) ( frame grid-layout quot1 quot2 -- ) (fill- -center) ; inline : (fill-center) ( frame grid-layout quot1 quot2 -- ) (fill- -center) ; inline
@ -35,7 +36,7 @@ M: glue pref-dim* drop { 0 0 } ;
[ [ second ] [ row-heights>> ] (fill-center) ] 2bi ; [ [ second ] [ row-heights>> ] (fill-center) ] 2bi ;
: <frame-layout> ( frame -- grid-layout ) : <frame-layout> ( frame -- grid-layout )
dup <grid-layout> [ fill-center ] keep ; dup <grid-layout> [ fill-center ] [ ] bi ;
PRIVATE> PRIVATE>

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

@ -85,7 +85,7 @@ M: gadget contains-point? ( loc gadget -- ? )
: pick-up ( point gadget -- child/f ) : pick-up ( point gadget -- child/f )
2dup [ dup point>rect ] dip children-on 2dup [ dup point>rect ] dip children-on
[ contains-point? ] with find-last nip [ contains-point? ] with find-last nip
[ [ loc>> v- ] keep pick-up ] [ nip ] ?if ; [ [ loc>> v- ] [ pick-up ] bi ] [ nip ] ?if ;
: max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ; : max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
@ -115,7 +115,7 @@ M: gadget gadget-text-separator
gadget-text-separator '[ _ % ] [ gadget-text* ] interleave ; gadget-text-separator '[ _ % ] [ gadget-text* ] interleave ;
M: gadget gadget-text* M: gadget gadget-text*
[ children>> ] keep gadget-seq-text ; [ children>> ] [ gadget-seq-text ] bi ;
M: array gadget-text* M: array gadget-text*
[ gadget-text* ] each ; [ gadget-text* ] each ;
@ -183,7 +183,7 @@ GENERIC: pref-dim* ( gadget -- dim )
: pref-dim ( gadget -- dim ) : pref-dim ( gadget -- dim )
dup pref-dim>> [ ] [ dup pref-dim>> [ ] [
[ pref-dim* ] keep dup layout-state>> [ pref-dim* ] [ dup layout-state>> ] bi
[ drop ] [ dupd (>>pref-dim) ] if [ drop ] [ dupd (>>pref-dim) ] if
] ?if ; ] ?if ;
@ -267,7 +267,7 @@ M: gadget ungraft* drop ;
: notify ( gadget -- ) : notify ( gadget -- )
dup graft-state>> dup graft-state>>
[ first { f f } { t t } ? >>graft-state ] keep [ first { f f } { t t } ? >>graft-state ] [ ] bi
{ {
{ { f t } [ dup activate-control graft* ] } { { f t } [ dup activate-control graft* ] }
{ { t f } [ dup deactivate-control ungraft* ] } { { t f } [ dup deactivate-control ungraft* ] }
@ -388,7 +388,7 @@ M: gadget request-focus-on parent>> request-focus-on ;
M: f request-focus-on 2drop ; M: f request-focus-on 2drop ;
: request-focus ( gadget -- ) : request-focus ( gadget -- )
[ focusable-child ] keep request-focus-on ; [ focusable-child ] [ request-focus-on ] bi ;
: focus-path ( gadget -- seq ) : focus-path ( gadget -- seq )
[ focus>> ] follow ; [ focus>> ] follow ;

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

@ -27,7 +27,9 @@ PRIVATE>
: grid-child ( grid pair -- gadget ) grid@ nth ; : grid-child ( grid pair -- gadget ) grid@ nth ;
: grid-add ( grid child pair -- grid ) : grid-add ( grid child pair -- grid )
[ nip grid-child unparent ] [ drop add-gadget ] [ swapd grid@ set-nth ] 3tri ; [ nip grid-child unparent ]
[ drop add-gadget ]
[ swapd grid@ set-nth ] 3tri ;
: grid-remove ( grid pair -- grid ) [ <gadget> ] dip grid-add ; : grid-remove ( grid pair -- grid ) [ <gadget> ] dip grid-add ;
@ -114,8 +116,7 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
M: grid children-on ( rect gadget -- seq ) M: grid children-on ( rect gadget -- seq )
dup children>> empty? [ 2drop f ] [ dup children>> empty? [ 2drop f ] [
[ { 0 1 } ] dip grid>> [ { 0 1 } ] dip grid>>
[ 0 <column> fast-children-on ] keep [ 0 <column> fast-children-on ] [ <slice> concat ] bi
<slice> concat
] if ; ] if ;
M: grid gadget-text* M: grid gadget-text*

2
basis/ui/gadgets/line-support/line-support.factor
View File

@ -79,7 +79,7 @@ PRIVATE>
[ second ] [ [ line-height ] [ min-rows>> ] [ max-rows>> ] tri ] bi* clamp ; [ second ] [ [ line-height ] [ min-rows>> ] [ max-rows>> ] tri ] bi* clamp ;
M: line-gadget pref-viewport-dim M: line-gadget pref-viewport-dim
[ pref-dim ] keep [ pref-dim ] [ ] bi
[ line-gadget-width ] [ line-gadget-width ]
[ line-gadget-height ] [ line-gadget-height ]
2bi 2array ; 2bi 2array ;

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

@ -307,7 +307,7 @@ PRIVATE>
'[ _ row-value eq? ] with find drop ; '[ _ row-value eq? ] with find drop ;
: (update-selected-indices) ( table -- set ) : (update-selected-indices) ( table -- set )
[ selection>> value>> dup [ array? not ] [ ] bi and [ 1array ] when ] keep [ selection>> value>> dup { [ array? not ] [ ] } 1&& [ 1array ] when ] keep
'[ _ find-row-index ] map sift unique f assoc-like ; '[ _ find-row-index ] map sift unique f assoc-like ;
: initial-selected-indices ( table -- set ) : initial-selected-indices ( table -- set )

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

@ -61,6 +61,7 @@ PRIVATE>
pick sizes>> push add-gadget ; pick sizes>> push add-gadget ;
M: track remove-gadget M: track remove-gadget
[ [ children>> index ] keep sizes>> delete-nth ] [ call-next-method ] 2bi ; [ [ children>> index ] [ sizes>> ] bi delete-nth ]
[ call-next-method ] 2bi ;
: clear-track ( track -- ) [ sizes>> delete-all ] [ clear-gadget ] bi ; : clear-track ( track -- ) [ sizes>> delete-all ] [ clear-gadget ] bi ;

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

@ -1,8 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel ui.commands USING: accessors arrays assocs combinators.short-circuit fry
ui.gestures sequences strings math words generic namespaces kernel linked-assocs namespaces sequences ui.commands words ;
hashtables quotations assocs fry linked-assocs ;
IN: ui.operations IN: ui.operations
SYMBOL: +keyboard+ SYMBOL: +keyboard+
@ -18,7 +17,7 @@ TUPLE: operation predicate command translator listener? ;
swap >>predicate ; swap >>predicate ;
PREDICATE: listener-operation < operation PREDICATE: listener-operation < operation
[ command>> listener-command? ] [ listener?>> ] bi or ; { [ command>> listener-command? ] [ listener?>> ] } 1|| ;
M: operation command-name M: operation command-name
command>> command-name ; command>> command-name ;

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

@ -1,14 +1,14 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: debugger classes help help.topics help.crossref help.home USING: accessors arrays assocs classes combinators
kernel models compiler.units assocs words vocabs accessors fry arrays combinators.short-circuit compiler.units debugger fry help
combinators.short-circuit namespaces sequences help.apropos help.apropos help.crossref help.home help.topics kernel models
combinators ui ui.commands ui.gadgets ui.gadgets.panes sequences ui ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.buttons ui.gadgets.editors ui.gadgets.glass
ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.viewports
ui.gadgets.viewports ui.tools.common ui.tools.browser.popups ui.gestures ui.tools.browser.history ui.tools.browser.popups
ui.tools.browser.history ; ui.tools.common vocabs ;
IN: ui.tools.browser IN: ui.tools.browser
TUPLE: browser-gadget < tool history scroller search-field popup ; TUPLE: browser-gadget < tool history scroller search-field popup ;
@ -95,8 +95,10 @@ M: browser-gadget focusable-child* search-field>> ;
"help.home" (browser-window) ; "help.home" (browser-window) ;
: error-help-window ( error -- ) : error-help-window ( error -- )
{
[ error-help ] [ error-help ]
[ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ; [ dup tuple? [ class ] [ drop "errors" ] if ]
} 1|| (browser-window) ;
\ browser-window H{ { +nullary+ t } } define-command \ browser-window H{ { +nullary+ t } } define-command

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

@ -150,11 +150,11 @@ M: interactor stream-readln
] if ; ] if ;
M: interactor stream-read M: interactor stream-read
swap dup zero? [ swap [
2drop "" drop ""
] [ ] [
[ interactor-read dup [ "\n" join ] when ] dip short head [ interactor-read dup [ "\n" join ] when ] dip short head
] if ; ] if-zero ;
M: interactor stream-read-partial M: interactor stream-read-partial
stream-read ; stream-read ;

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

@ -1,14 +1,15 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel quotations accessors fry assocs present math.order USING: accessors arrays assocs combinators.short-circuit
math.vectors arrays locals models.search models.sort models sequences combinators.smart definitions.icons fry kernel locals
vocabs tools.profiler words prettyprint combinators.smart math.order models models.search models.sort present see
definitions.icons see ui ui.commands ui.gadgets ui.gadgets.panes sequences tools.profiler ui.baseline-alignment ui.commands
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled ui.gadgets.labeled ui.gadgets.labels ui.gadgets.packs
ui.gadgets.packs ui.gadgets.labels ui.gadgets.tabbed ui.gadgets.search-tables ui.gadgets.status-bar
ui.gadgets.status-bar ui.gadgets.borders ui.tools.browser ui.gadgets.tabbed ui.gadgets.tables ui.gadgets.tracks
ui.tools.common ui.baseline-alignment ui.operations ui.images ; ui.gestures ui.images ui.operations ui.tools.browser
ui.tools.common vocabs words ;
FROM: models.arrow => <arrow> ; FROM: models.arrow => <arrow> ;
FROM: models.arrow.smart => <smart-arrow> ; FROM: models.arrow.smart => <smart-arrow> ;
FROM: models.product => <product> ; FROM: models.product => <product> ;
@ -105,9 +106,10 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ;
: method-matches? ( method generic class -- ? ) : method-matches? ( method generic class -- ? )
[ first ] 2dip [ first ] 2dip
{
[ drop dup [ subwords memq? ] [ 2drop t ] if ] [ drop dup [ subwords memq? ] [ 2drop t ] if ]
[ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ] [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ]
3bi and ; } 3&& ;
: <methods-model> ( profiler -- model ) : <methods-model> ( profiler -- model )
[ [