! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.mixin classes.parser classes.singleton
-classes.tuple classes.tuple.parser combinators effects effects.parser
-fry generic generic.parser generic.standard interpolate
-io.streams.string kernel lexer locals.parser locals.rewrite.closures
-locals.types make namespaces parser quotations sequences vocabs.parser
-words words.symbol ;
+USING: accessors arrays classes.mixin classes.parser
- classes.tuple classes.tuple.parser combinators effects
- effects.parser fry generic generic.parser generic.standard
- interpolate io.streams.string kernel lexer locals.parser
- locals.rewrite.closures locals.types make macros namespaces
- parser quotations sequences vocabs.parser words words.symbol ;
++classes.singleton classes.tuple classes.tuple.parser
++combinators effects.parser fry generic generic.parser
++generic.standard interpolate io.streams.string kernel lexer
++locals.parser locals.types macros make namespaces parser
++quotations sequences vocabs.parser words words.symbol ;
IN: functors
! This is a hack
} case
\ define-tuple-class parsed ;
+ SYNTAX: `SINGLETON:
+ scan-param parsed
+ \ define-singleton-class parsed ;
+
+ SYNTAX: `MIXIN:
+ scan-param parsed
+ \ define-mixin-class parsed ;
+
SYNTAX: `M:
scan-param parsed
scan-param parsed
complete-effect parsed
\ define-simple-generic* parsed ;
+SYNTAX: `MACRO:
+ scan-param parsed
+ parse-declared*
+ \ define-macro parsed ;
+
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
+ SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
+
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
: functor-words ( -- assoc )
H{
{ "TUPLE:" POSTPONE: `TUPLE: }
+ { "SINGLETON:" POSTPONE: `SINGLETON: }
+ { "MIXIN:" POSTPONE: `MIXIN: }
{ "M:" POSTPONE: `M: }
{ "C:" POSTPONE: `C: }
{ ":" POSTPONE: `: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline }
+ { "MACRO:" POSTPONE: `MACRO: }
{ "call-next-method" POSTPONE: `call-next-method }
} ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays colors colors.constants fry kernel math
-math.functions math.rectangles math.order math.vectors namespaces
-opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
-ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
-ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
-models math.ranges combinators
-combinators.short-circuit fonts locals strings ;
+math.functions math.ranges math.rectangles math.order math.vectors
+models.illusion namespaces opengl sequences ui.gadgets
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds
+ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images
+ui.gadgets.menus ui.gadgets.line-support models
+combinators combinators.short-circuit
+fonts locals strings sorting ;
IN: ui.gadgets.tables
! Row rendererer protocol
{ mouse-color initial: COLOR: black }
column-line-color
selection-required?
-selected-index selected-value
+selected-indices selected-values
+selected-indices*
mouse-index
{ takes-focus? initial: t }
-focused? ;
+focused?
+multiple-selection? ;
+
+: in>out ( array -- val/f ) [ f ] [ first ] if-empty ;
+: out>in ( val/f -- array ) [ 1array ] [ { } ] if* ;
+IN: accessors
+SLOT: selected-value
+SLOT: selected-index
+SLOT: selected-index*
+M: table selected-value>> selected-values>> [ in>out ] <illusion> ;
+M: table (>>selected-value) [ [ out>in ] <activated-illusion> ] dip (>>selected-values) ;
+M: table selected-index>> selected-indices>> in>out ;
+M: table (>>selected-index) [ out>in ] dip (>>selected-indices) ;
+M: table selected-index*>> selected-indices*>> [ in>out ] <illusion> ;
+M: table (>>selected-index*) [ [ out>in ] <activated-illusion> ] dip (>>selected-indices*) ;
+
+IN: ui.gadgets.tables
+: push-selected-index ( table n -- table ) 2dup swap selected-indices>> index
+ [ drop ] [ over selected-indices>> swap suffix natural-sort >>selected-indices ] if ;
: new-table ( rows renderer class -- table )
new-line-gadget
swap >>renderer
swap >>model
- f <model> >>selected-value
+ { } >>selected-indices
+ { } <model> >>selected-values
+ { } <model> >>selected-indices*
sans-serif-font >>font
focus-border-color >>focus-border-color
transparent >>column-line-color ; inline
: row-bounds ( table row -- loc dim )
row-rect rect-bounds ; inline
-: draw-selected-row ( table -- )
+: draw-selected-rows ( table -- )
{
- { [ dup selected-index>> not ] [ drop ] }
+ { [ dup selected-indices>> empty? ] [ drop ] }
[
- [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
- row-bounds gl-fill-rect
+ [ selected-indices>> ] [ selection-color>> gl-color ] [ ] tri
+ [ swap row-bounds gl-fill-rect ] curry each
]
} cond ;
dup renderer>> column-alignment
[ ] [ column-widths>> length 0 <repetition> ] ?if ;
-:: row-font ( row index table -- font )
+:: row-font ( row ind table -- font )
table font>> clone
row table renderer>> row-color [ >>foreground ] when*
- index table selected-index>> = [ table selection-color>> >>background ] when ;
+ ind table selected-indices>> index [ table selection-color>> >>background ] when ;
: draw-columns ( columns widths alignment font gap -- )
'[ [ _ ] 3dip _ draw-column ] 3each ;
dup control-value empty? [ drop ] [
dup line-height \ line-height [
{
- [ draw-selected-row ]
+ [ draw-selected-rows ]
[ draw-lines ]
[ draw-column-lines ]
[ draw-focused-row ]
PRIVATE>
-: (selected-row) ( table -- value/f ? )
- [ selected-index>> ] keep nth-row ;
+: (selected-rows) ( table -- {row} )
+ [ selected-indices>> ] keep
+ [ nth-row [ 1array ] [ drop { } ] if ] curry map concat ;
-: selected-row ( table -- value/f ? )
- [ (selected-row) ] keep
- swap [ renderer>> row-value t ] [ 2drop f f ] if ;
+: selected-rows ( table -- {value} )
+ [ (selected-rows) ] [ renderer>> ] bi [ row-value ] curry map ;
+
+: multiple>single ( values -- value/f ? ) [ f f ] [ first t ] if-empty ;
+: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ;
+: selected-row ( table -- value/f ? ) selected-rows multiple>single ;
<PRIVATE
-: update-selected-value ( table -- )
- [ selected-row drop ] [ selected-value>> ] bi set-model ;
+: update-selected-values ( table -- )
+ [ [ selected-rows ] [ selected-values>> ] bi set-model ]
+ [ [ selected-indices>> ] [ selected-indices*>> ] bi set-model ] bi ;
: show-row-summary ( table n -- )
over nth-row
: find-row-index ( value table -- n/f )
[ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
-: initial-selected-index ( table -- n/f )
+: initial-selected-indices ( table -- {n}/f )
{
[ model>> value>> empty? not ]
[ selection-required?>> ]
- [ drop 0 ]
+ [ drop { 0 } ]
} 1&& ;
-: (update-selected-index) ( table -- n/f )
- [ selected-value>> value>> ] keep over
- [ find-row-index ] [ 2drop f ] if ;
+: (update-selected-indices) ( table -- {n}/f )
+ [ selected-values>> value>> ] keep
+ [ find-row-index ] curry map [ ] filter [ f ] when-empty ;
-: update-selected-index ( table -- n/f )
+: update-selected-indices ( table -- {n}/f )
{
- [ (update-selected-index) ]
- [ initial-selected-index ]
+ [ (update-selected-indices) ]
+ [ initial-selected-indices ]
} 1|| ;
M: table model-changed
- nip dup update-selected-index {
- [ >>selected-index f >>mouse-index drop ]
- [ show-row-summary ]
- [ drop update-selected-value ]
+ nip dup update-selected-indices [ { } ] unless* {
+ [ >>selected-indices f >>mouse-index drop ]
+ [ [ f ] [ first ] if-empty show-row-summary ]
+ [ drop update-selected-values ]
[ drop relayout ]
} 2cleave ;
: thin-row-rect ( table row -- rect )
row-rect [ { 0 1 } v* ] change-dim ;
+: scroll-to-row ( table n -- )
+ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ;
+
+: add-selected-row ( table n -- )
+ [ scroll-to-row ]
+ [ push-selected-index relayout-1 ] 2bi ;
+
: (select-row) ( table n -- )
- [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
+ [ scroll-to-row ]
[ >>selected-index relayout-1 ]
2bi ;
: mouse-row ( table -- n )
[ hand-rel second ] keep y>line ;
-: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+: if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
[ [ mouse-row ] keep 2dup valid-line? ]
[ ] [ '[ nip @ ] ] tri* if ; inline
-: table-button-down ( table -- )
- dup takes-focus?>> [ dup request-focus ] when
- [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
+: (table-button-down) ( quot table -- )
+ dup takes-focus?>> [ dup request-focus ] when swap
+ '[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline
+
+: table-button-down ( table -- ) [ (select-row) ] swap (table-button-down) ;
+: continued-button-down ( table -- ) dup multiple-selection?>> [ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ;
+: thru-button-down ( table -- ) dup multiple-selection?>> [
+ [ 2dup over selected-index>> (a,b) swap
+ [ swap push-selected-index drop ] curry each add-selected-row ]
+ swap (table-button-down) ] [ table-button-down ] if ;
PRIVATE>
if ;
: row-action? ( table -- ? )
- [ [ mouse-row ] keep valid-line? ]
- [ single-click?>> hand-click# get 2 = or ] bi and ;
+ single-click?>> hand-click# get 2 = or ;
<PRIVATE
: table-button-up ( table -- )
- dup row-action? [ row-action ] [ update-selected-values ] if ;
+ dup [ mouse-row ] keep valid-line? [
- dup row-action? [ row-action ] [ update-selected-value ] if
++ dup row-action? [ row-action ] [ update-selected-values ] if
+ ] [ drop ] if ;
PRIVATE>
: select-row ( table n -- )
over validate-line
[ (select-row) ]
- [ drop update-selected-value ]
+ [ drop update-selected-values ]
[ show-row-summary ]
2tri ;
{ mouse-enter show-mouse-help }
{ mouse-leave hide-mouse-help }
{ motion show-mouse-help }
- { T{ button-down } table-button-down }
+ { T{ button-down f { S+ } 1 } thru-button-down }
+ { T{ button-down f { A+ } 1 } continued-button-down }
{ T{ button-up } table-button-up }
+ { T{ button-up f { S+ } } table-button-up }
+ { T{ button-down } table-button-down }
{ gain-focus focus-table }
{ lose-focus unfocus-table }
{ T{ drag } table-button-down }
projects / factor.git / commitdiff