contrib/action-field.factor

   1 USING: kernel models namespaces math sequences arrays hashtables
   2 gadgets gadgets-text gadgets-buttons generic ;
   3 IN: action-field
   4
   5 TUPLE: field model ;
   6
   7 C: field ( model -- field )
   8 <editor> over set-delegate
   9 [ set-field-model ] keep
  10 dup dup set-control-self ;
  11
  12 : field-commit ( field -- string )
  13 [ editor-text ] keep
  14 [ field-model [ dupd set-model ] when* ] keep
  15 select-all ;
  16
  17 field "Field commands" {
  18     { "Clear input" T{ key-down f { C+ } "k" } [ control-model clear-doc ] }
  19     { "Accept input" T{ key-down f f "RETURN" } [ field-commit drop ] }
  20 } define-commands
  21
  22 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  23
  24 TUPLE: action-field quot ;
  25
  26 C: action-field ( quot -- action-field )
  27 tuck set-action-field-quot f <model> [ add-connection ] 2keep
  28 <field> over set-gadget-delegate ;
  29
  30 M: action-field model-changed ( action-field -- ) dup action-field-quot call ;
  31
  32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  33
  34 : variable-field ( var -- action-field )
  35 unit [ editor-text ] swap append [ set ] append <action-field> ;
  36
  37 : number-field ( var -- action-field )
  38 unit [ editor-text string>number ] swap append [ set ] append <action-field> ;
  39
  40 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  41 ! [bind] [unbind] and [bound?] should probably be in a separate
  42 ! file. But right now boids and automata are the only programs which
  43 ! use this, and I don't want to add a new contrib file just for
  44 ! this. For now they'll live here. Maybe bind-button and
  45 ! bind-action-field should go into a gadgets-utils file eventually.
  46 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  47
  48 : [bind] ( ns quot -- quot ) \ bind 3array >quotation ;
  49
  50 : [unbind] ( quot -- quot ) second ;
  51
  52 : [bound?] ( quot -- ? )
  53 dup length 3 = [ dup first hashtable? swap third \ bind = and ] [ f ] if ;
  54
  55 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  56
  57 : bind-button ( ns button -- ) tuck button-quot [bind] swap set-button-quot ;
  58
  59 : bind-action-field ( ns action-field -- )
  60 tuck action-field-quot [bind] swap set-action-field-quot ;
  61
  62 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  63
  64 PROVIDE: contrib/action-field ;