unmaintained/ui/gadgets/controls/controls.factor

   1 USING: accessors assocs arrays kernel models monads sequences
   2 models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
   3 ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.editors.private
   4 words images.loader ui.gadgets.scrollers ui.images vocabs.parser lexer
   5 models.range ui.gadgets.sliders ;
   6 QUALIFIED-WITH: ui.gadgets.sliders slider
   7 QUALIFIED-WITH: ui.gadgets.tables tbl
   8 EXCLUDE: ui.gadgets.editors => model-field ;
   9 IN: ui.gadgets.controls
  10
  11 TUPLE: model-btn < button hook value ;
  12 : <model-btn> ( gadget -- button ) [
  13       [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
  14       [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
  15       [ model>> f swap value<< ] tri
  16    ] model-btn new-button f <basic> >>model ;
  17 : <model-border-btn> ( text -- button ) <model-btn> border-button-theme ;
  18
  19 TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ;
  20 M: table tbl:column-titles column-titles>> ;
  21 M: table tbl:column-alignment column-alignment>> ;
  22 M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
  23 M: table tbl:row-value val-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
  24 M: table tbl:row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
  25
  26 : new-table ( model class -- table ) f swap tbl:new-table dup >>renderer
  27    f <basic> >>actions dup actions>> [ set-model ] curry >>action ;
  28 : <table> ( model -- table ) table new-table ;
  29 : <table*> ( -- table ) V{ } clone <model> <table> ;
  30 : <list> ( column-model -- table ) <table> [ 1array ] >>quot ;
  31 : <list*> ( -- table ) V{ } clone <model> <list> ;
  32 : indexed ( table -- table ) f >>val-quot ;
  33
  34 TUPLE: model-field < field model* ;
  35 : init-field ( model -- model' ) [ [ ] [ "" ] if* ] change-value ;
  36 : <model-field> ( model -- gadget ) model-field new-field swap init-field >>model* ;
  37 M: model-field graft*
  38     [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ]
  39     [ dup editor>> model>> add-connection ]
  40     [ dup model*>> add-connection ] tri ;
  41 M: model-field ungraft*
  42    [ dup editor>> model>> remove-connection ]
  43    [ dup model*>> remove-connection ] bi ;
  44 M: model-field model-changed 2dup model*>> =
  45     [ [ value>> ] [ editor>> ] bi* set-editor-string ]
  46     [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ;
  47
  48 : (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor
  49     field-theme { 1 0 } >>align ; inline
  50 : <model-field*> ( -- field ) "" <model> <model-field> ;
  51 : <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
  52 : <model-editor> ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ;
  53 : <model-editor*> ( -- editor ) "" <model> <model-editor> ;
  54 : <empty-editor> ( model -- editor ) "" <model> switch-models <model-editor> ;
  55
  56 : <model-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
  57     f <model> >>model ;
  58
  59 : <slider> ( init page min max step -- slider ) <range> horizontal slider:<slider> ;
  60
  61 : image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround <image-name> dup cached-image drop ;
  62 SYNTAX: IMG-MODEL-BTN: image-prep [ <model-btn> ] curry append! ;
  63
  64 SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry append! ;
  65
  66 GENERIC: output-model ( gadget -- model )
  67 M: gadget output-model model>> ;
  68 M: table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] if ;
  69 M: model-field output-model model*>> ;
  70 M: scroller output-model viewport>> children>> first output-model ;
  71 M: slider output-model model>> range-model ;
  72
  73 IN: accessors
  74 M: model-btn text>> children>> first text>> ;
  75
  76 IN: ui.gadgets.controls
  77
  78 SINGLETON: gadget-monad
  79 INSTANCE: gadget-monad monad
  80 INSTANCE: gadget monad
  81 M: gadget monad-of drop gadget-monad ;
  82 M: gadget-monad return drop <gadget> swap >>model ;
  83 M: gadget >>= output-model [ swap call( x -- y ) ] curry ;