extra/state-machine/state-machine.factor

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