diff --git a/basis/editors/textmate/textmate.factor b/basis/editors/textmate/textmate.factor index 65395bd590..561beee4e3 100644 --- a/basis/editors/textmate/textmate.factor +++ b/basis/editors/textmate/textmate.factor @@ -6,4 +6,4 @@ IN: editors.textmate [ "mate" , "-a" , "-l" , number>string , , ] { } make run-detached drop ; -[ textmate ] edit-hook set-global +[ textmate ] edit-hook set-global \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 5129515980..5f519aeece 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! 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.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 @@ -117,6 +117,11 @@ SYNTAX: `GENERIC: 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 ; @@ -152,6 +157,7 @@ DEFER: ;FUNCTOR delimiter { "SYNTAX:" POSTPONE: `SYNTAX: } { "SYMBOL:" POSTPONE: `SYMBOL: } { "inline" POSTPONE: `inline } + { "MACRO:" POSTPONE: `MACRO: } { "call-next-method" POSTPONE: `call-next-method } } ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index cf97a0b2c8..7a9e821b37 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel words summary slots quotations +USING: accessors kernel locals words summary slots quotations sequences assocs math arrays stack-checker effects continuations debugger classes.tuple namespaces make vectors bit-arrays byte-arrays strings sbufs math.functions macros @@ -231,6 +231,18 @@ DEFER: __ \ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ inputsequence ] ] define-pop-inverse +! conditionals + +:: undo-if-empty ( result a b -- seq ) + a call( -- b ) result = [ { } ] [ result b [undo] call( a -- b ) ] if ; + +:: undo-if* ( result a b -- boolean ) + b call( -- b ) result = [ f ] [ result a [undo] call( a -- b ) ] if ; + +\ if-empty 2 [ swap [ undo-if-empty ] 2curry ] define-pop-inverse + +\ if* 2 [ swap [ undo-if* ] 2curry ] define-pop-inverse + ! Constructor inverse : deconstruct-pred ( class -- quot ) "predicate" word-prop [ dupd call assure ] curry ; @@ -283,4 +295,4 @@ M: no-match summary drop "Fall through in switch" ; reverse [ [ [undo] ] dip compose ] { } assoc>map recover-chain ; -MACRO: switch ( quot-alist -- ) [switch] ; +MACRO: switch ( quot-alist -- ) [switch] ; \ No newline at end of file diff --git a/extra/str-fry/authors.txt b/basis/models/illusion/authors.txt similarity index 100% rename from extra/str-fry/authors.txt rename to basis/models/illusion/authors.txt diff --git a/basis/models/illusion/illusion.factor b/basis/models/illusion/illusion.factor new file mode 100644 index 0000000000..00169792a9 --- /dev/null +++ b/basis/models/illusion/illusion.factor @@ -0,0 +1,15 @@ +USING: accessors models models.arrow inverse kernel ; +IN: models.illusion + +TUPLE: illusion < arrow ; + +: ( model quot -- illusion ) + illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref + swap >>quot over >>model [ add-dependency ] keep ; + +: ( model quot -- illusion ) dup activate-model ; + +: backtalk ( value object -- ) + [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ; + +M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ; \ No newline at end of file diff --git a/basis/models/illusion/summary.txt b/basis/models/illusion/summary.txt new file mode 100644 index 0000000000..8ea7cf1e7d --- /dev/null +++ b/basis/models/illusion/summary.txt @@ -0,0 +1 @@ +Two Way Arrows \ No newline at end of file diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor index fc564b6ffe..9f55c7a67d 100644 --- a/basis/ui/gadgets/search-tables/search-tables.factor +++ b/basis/ui/gadgets/search-tables/search-tables.factor @@ -58,7 +58,7 @@ mouse-color column-line-color selection-required? single-click? -selected-value +selection min-rows min-cols max-rows diff --git a/basis/ui/gadgets/tables/tables-docs.factor b/basis/ui/gadgets/tables/tables-docs.factor index c064a80ee4..81e5f0f778 100644 --- a/basis/ui/gadgets/tables/tables-docs.factor +++ b/basis/ui/gadgets/tables/tables-docs.factor @@ -16,17 +16,17 @@ $nl { $subsection column-titles } ; ARTICLE: "ui.gadgets.tables.selection" "Table row selection" -"At any given time, a single row in the table may be selected." -$nl "A few slots in the table gadget concern row selection:" { $table - { { $slot "selected-value" } { " - if set to a model, the currently selected row's value, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } } - { { $slot "selected-index" } " - the index of the currently selected row." } + { { $slot "selection" } { " - if set to a model, the values of the currently selected row or rows, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } } + { { $slot "selection-index" } { " - if set to a model, the indices of the currently selected rows." } } { { $slot "selection-required?" } { " - if set to a true value, the table ensures that some row is always selected, if the model is non-empty. If set to " { $link f } ", a state where nothing is selected is permitted to occur. The default is " { $link f } "." } } + { { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } } } "Some words for row selection:" -{ $subsection selected-row } -{ $subsection (selected-row) } ; +{ $subsection selected-rows } +{ $subsection (selected-rows) } +{ $subsection selected } ; ARTICLE: "ui.gadgets.tables.actions" "Table row actions" "When the user double-clicks on a row, or presses " { $command table "row" row-action } " while a row is selected, optional action and hook quotations are invoked. The action receives the row value and the hook receives the table gadget itself. These quotations are stored in the " { $slot "action" } " and " { $snippet "hook" } " slots of a table, respectively." diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 3beb0af79f..bb70173455 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -1,12 +1,13 @@ ! 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 sequences.extras sets ; IN: ui.gadgets.tables ! Row rendererer protocol @@ -41,19 +42,35 @@ focus-border-color { mouse-color initial: COLOR: black } column-line-color selection-required? -selected-index selected-value +selection +selection-index +selected-indices mouse-index { takes-focus? initial: t } -focused? ; +focused? +multiple-selection? ; + +array ] change-selected-indices ; +: multiple>single ( values -- value/f ? ) [ f f ] [ first t ] if-empty ; +: multiple>single* ( values -- value/f ) multiple>single drop ; +: selected-index ( table -- n ) selected-indices>> multiple>single* ; +: set-selected-index ( table n -- table ) 1array >>selected-indices ; +PRIVATE> +: selected ( table -- index/indices ) dup multiple-selection?>> + [ selected-indices>> ] [ selected-index ] if ; : new-table ( rows renderer class -- table ) new-line-gadget swap >>renderer swap >>model - f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; inline + transparent >>column-line-color + f >>selection-index + f >>selection ; : ( rows renderer -- table ) table new-table ; @@ -131,21 +148,21 @@ M: table layout* : 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 ; : draw-focused-row ( table -- ) { { [ dup focused?>> not ] [ drop ] } - { [ dup selected-index>> not ] [ drop ] } + { [ dup selected-index not ] [ drop ] } [ - [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri + [ ] [ selected-index ] [ focus-border-color>> gl-color ] tri row-bounds gl-rect ] } cond ; @@ -189,10 +206,10 @@ M: table layout* dup renderer>> column-alignment [ ] [ column-widths>> length 0 ] ?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 ; @@ -213,7 +230,7 @@ M: table draw-gadget* dup control-value empty? [ drop ] [ dup line-height \ line-height [ { - [ draw-selected-row ] + [ draw-selected-rows ] [ draw-lines ] [ draw-column-lines ] [ draw-focused-row ] @@ -236,17 +253,26 @@ M: table pref-dim* 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 ; +: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ; +: selected-row ( table -- value/f ? ) selected-rows multiple>single ; > ] bi set-model ; +: set-table-model ( model value multiple? -- ) + [ multiple>single* ] unless swap set-model ; + +: update-selected ( table -- ) + [ [ selection>> ] [ selected-rows ] [ multiple-selection?>> ] tri set-table-model ] + [ + [ selection-index>> ] [ selected-indices>> ] [ multiple-selection?>> ] tri + set-table-model + ] bi ; : show-row-summary ( table n -- ) over nth-row @@ -260,49 +286,65 @@ PRIVATE> : 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 ) + [ selection>> value>> dup array? [ 1array ] unless ] 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 ] [ 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 ] - [ >>selected-index relayout-1 ] + [ scroll-to-row ] + [ set-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> @@ -319,7 +361,7 @@ PRIVATE> : table-button-up ( table -- ) dup [ mouse-row ] keep valid-line? [ - dup row-action? [ row-action ] [ update-selected-value ] if + dup row-action? [ row-action ] [ update-selected ] if ] [ drop ] if ; PRIVATE> @@ -327,14 +369,14 @@ PRIVATE> : select-row ( table n -- ) over validate-line [ (select-row) ] - [ drop update-selected-value ] + [ drop update-selected ] [ show-row-summary ] 2tri ; > ] dip '[ _ + ] [ 0 ] if* select-row ; + [ dup selected-index ] dip '[ _ + ] [ 0 ] if* select-row ; : previous-row ( table -- ) -1 prev/next-row ; @@ -386,8 +428,11 @@ table "sundry" f { { 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 } diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index e9d4b50bac..1193ca237c 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -71,7 +71,7 @@ M: source-file-renderer filled-column drop 1 ; 60 >>min-cols 60 >>max-cols t >>selection-required? - error-list source-file>> >>selected-value ; + error-list source-file>> >>selection ; SINGLETON: error-renderer @@ -120,7 +120,7 @@ M: error-renderer column-alignment drop { 0 1 0 0 } ; 60 >>min-cols 60 >>max-cols t >>selection-required? - error-list error>> >>selected-value ; + error-list error>> >>selection ; TUPLE: error-display < track ; diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor old mode 100644 new mode 100755 diff --git a/extra/closures/closures.factor b/extra/closures/closures.factor new file mode 100644 index 0000000000..79fcf7564e --- /dev/null +++ b/extra/closures/closures.factor @@ -0,0 +1,13 @@ +USING: assocs io.pathnames fry namespaces namespaces.private kernel sequences parser hashtables ; +IN: closures +SYMBOL: | + +! Selective Binding +: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip >hashtable [ _ bind ] curry ] ; +SYNTAX: C[ | parse-until parse-quotation delayed-bind-with over push-all ; +! Common ones +SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with over push-all ; + +! Namespace Binding +: bind-to-namespace ( quot -- quot' ) '[ namespace [ _ bind ] curry ] ; +SYNTAX: NS[ parse-quotation bind-to-namespace over push-all ; \ No newline at end of file diff --git a/extra/db/info/info.factor b/extra/db/info/info.factor new file mode 100644 index 0000000000..66409f2834 --- /dev/null +++ b/extra/db/info/info.factor @@ -0,0 +1,15 @@ +USING: accessors sequences generalizations io.encodings.utf8 db.postgresql parser combinators vocabs.parser db.sqlite +io.files ; +IN: db.info +! having sensative (and likely to change) information directly in source code seems a bad idea +: get-info ( -- lines ) current-vocab name>> "vocab:" "/dbinfo.txt" surround utf8 file-lines ; +SYNTAX: get-psql-info get-info 5 firstn + { + [ >>host ] + [ >>port ] + [ >>username ] + [ [ f ] [ ] if-empty >>password ] + [ >>database ] + } spread parsed ; + +SYNTAX: get-sqlite-info get-info first parsed ; \ No newline at end of file diff --git a/extra/drills/deployed/deploy.factor b/extra/drills/deployed/deploy.factor index eaa0d3bb69..c1e93078f7 100644 --- a/extra/drills/deployed/deploy.factor +++ b/extra/drills/deployed/deploy.factor @@ -1,14 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-unicode? f } - { deploy-threads? t } - { deploy-math? t } { deploy-name "drills" } - { deploy-ui? t } + { deploy-c-types? t } { "stop-after-last-window?" t } - { deploy-word-props? f } - { deploy-c-types? f } - { deploy-io 2 } - { deploy-word-defs? f } - { deploy-reflection 1 } + { deploy-unicode? t } + { deploy-threads? t } + { deploy-reflection 6 } + { deploy-word-defs? t } + { deploy-math? t } + { deploy-ui? t } + { deploy-word-props? t } + { deploy-io 3 } } diff --git a/extra/drills/deployed/deployed.factor b/extra/drills/deployed/deployed.factor index 43873c99bb..5681c73438 100644 --- a/extra/drills/deployed/deployed.factor +++ b/extra/drills/deployed/deployed.factor @@ -1,11 +1,11 @@ -USING: accessors arrays cocoa.dialogs combinators continuations +USING: arrays cocoa.dialogs combinators continuations fry grouping io.encodings.utf8 io.files io.styles kernel math math.parser models models.arrow models.history namespaces random sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts wrap.strings system ; - +EXCLUDE: accessors => change-model ; IN: drills.deployed SYMBOLS: it startLength ; : big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ; diff --git a/extra/drills/drills.factor b/extra/drills/drills.factor index 9ee4e9b6eb..1da1fcaa1d 100644 --- a/extra/drills/drills.factor +++ b/extra/drills/drills.factor @@ -1,16 +1,17 @@ -USING: accessors arrays cocoa.dialogs combinators continuations +USING: arrays cocoa.dialogs combinators continuations fry grouping io.encodings.utf8 io.files io.styles kernel math math.parser models models.arrow models.history namespaces random sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts wrap.strings ; +EXCLUDE: accessors => change-model ; IN: drills SYMBOLS: it startLength ; : big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ; : card ( model quot -- button ) big [ next ] ; -: op ( quot str -- gadget )
+{ $values { "model" "values the table is to display" } { "table" table } } +{ $description "Creates an " { $link table } } ; + +HELP: +{ $values { "table" table } } +{ $description "Creates an " { $link table } " with no initial values to display" } ; + +HELP: +{ $values { "column-model" "values the table is to display" } { "table" table } } +{ $description "Creates an " { $link table } " with a val-quot that renders each element as its own row" } ; + +HELP: +{ $values { "table" table } } +{ $description "Creates an model-list with no initial values to display" } ; + +HELP: indexed +{ $values { "table" table } } +{ $description "Sets the output model of an table to the selected-index, rather than the selected-value" } ; + +HELP: +{ $values { "model" model } { "gadget" model-field } } +{ $description "Creates a field with an initial value" } ; + +HELP: +{ $values { "field" model-field } } +{ $description "Creates a field with an empty initial value" } ; + +HELP: +{ $values { "model" model } { "field" model-field } } +{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ; + +HELP: +{ $values { "model" model } { "gadget" model-field } } +{ $description "Creates an editor with an initial value" } ; + +HELP: +{ $values { "editor" "an editor" } } +{ $description "Creates a editor with an empty initial value" } ; + +HELP: +{ $values { "model" model } { "editor" "an editor" } } +{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ; + +HELP: +{ $values { "field" action-field } } +{ $description "Field that updates its model with its contents when the user hits the return key" } ; + +HELP: IMG-MODEL-BTN: +{ $syntax "IMAGE-MODEL-BTN: filename" } +{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ; + +HELP: IMG-BTN: +{ $syntax "[ do-something ] IMAGE-BTN: filename" } +{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ; + +HELP: output-model +{ $values { "gadget" gadget } { "model" model } } +{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ; \ No newline at end of file diff --git a/extra/ui/gadgets/controls/controls.factor b/extra/ui/gadgets/controls/controls.factor new file mode 100644 index 0000000000..649c9052fd --- /dev/null +++ b/extra/ui/gadgets/controls/controls.factor @@ -0,0 +1,83 @@ +USING: accessors assocs arrays kernel models monads sequences +models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons +ui.gadgets.buttons.private ui.gadgets.editors words images.loader +ui.gadgets.scrollers ui.images vocabs.parser lexer +models.range ui.gadgets.sliders ; +QUALIFIED-WITH: ui.gadgets.sliders slider +QUALIFIED-WITH: ui.gadgets.tables tbl +EXCLUDE: ui.gadgets.editors => model-field ; +IN: ui.gadgets.controls + +TUPLE: model-btn < button hook value ; +: ( gadget -- button ) [ + [ dup hook>> [ call( button -- ) ] [ drop ] if* ] + [ [ [ value>> ] [ ] bi or ] keep set-control-value ] + [ model>> f swap (>>value) ] tri + ] model-btn new-button f >>model ; +: ( text -- button ) border-button-theme ; + +TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ; +M: table tbl:column-titles column-titles>> ; +M: table tbl:column-alignment column-alignment>> ; +M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ; +M: table tbl:row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ; +M: table tbl:row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; + +: new-table ( model class -- table ) f swap tbl:new-table dup >>renderer + f >>actions dup actions>> [ set-model ] curry >>action ; +:
( model -- table ) table new-table ; +: ( -- table ) V{ } clone
; +: ( column-model -- table )
[ 1array ] >>quot ; +: ( -- table ) V{ } clone ; +: indexed ( table -- table ) f >>val-quot ; + +TUPLE: model-field < field model* ; +: init-field ( model -- model' ) [ [ ] [ "" ] if* ] change-value ; +: ( model -- gadget ) model-field new-field swap init-field >>model* ; +M: model-field graft* + [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ] + [ dup editor>> model>> add-connection ] + [ dup model*>> add-connection ] tri ; +M: model-field ungraft* + [ dup editor>> model>> remove-connection ] + [ dup model*>> remove-connection ] bi ; +M: model-field model-changed 2dup model*>> = + [ [ value>> ] [ editor>> ] bi* set-editor-string ] + [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ; + +: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor + field-theme { 1 0 } >>align ; inline +: ( -- field ) "" ; +: ( model -- field ) "" switch-models ; +: ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ; +: ( -- editor ) "" ; +: ( model -- editor ) "" switch-models ; + +: ( -- field ) f dup [ set-control-value ] curry >>quot + f >>model ; + +: ( init page min max step -- slider ) horizontal slider: ; + +: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround dup cached-image drop ; +SYNTAX: IMG-MODEL-BTN: image-prep [ ] curry over push-all ; + +SYNTAX: IMG-BTN: image-prep [ swap