extra/state-machine/state-machine.factor

   1 USING: kernel parser strings math namespaces sequences words io
   2 arrays quotations debugger kernel.private sequences.private ;
   3 IN: state-machine
   4
   5 : STATES:
   6     ! STATES: set-name state1 state2 ... ;
   7     ";" parse-tokens
   8     [ length ] keep
   9     unclip suffix
  10     [ create-in swap 1quotation define ] 2each ; parsing
  11
  12 TUPLE: state place data ;
  13
  14 ERROR: missing-state ;
  15
  16 M: missing-state error.
  17     drop "Missing state" print ;
  18
  19 : make-machine ( states -- table quot )
  20     ! quot is ( state string -- output-string )
  21     [ missing-state ] <array> dup
  22     [
  23         [ >r dup dup state-data swap state-place r> ] %
  24         [ swapd bounds-check dispatch ] curry ,
  25         [ each pick set-state-place swap set-state-data ] %
  26     ] [ ] make [ over make ] curry ;
  27
  28 : define-machine ( word state-class -- )
  29     execute make-machine
  30     >r over r> define
  31     "state-table" set-word-prop ;
  32
  33 : MACHINE:
  34     ! MACHINE: utf8 unicode-states
  35     CREATE scan-word define-machine ; parsing
  36
  37 : S:
  38     ! S: state state-machine definition... ;
  39     ! definition MUST be ( data char -- newdata state )
  40     scan-word execute scan-word "state-table" word-prop
  41     parse-definition -rot set-nth ; parsing