extra/state-tables/state-tables.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel namespaces sequences vectors assocs accessors ;
   4 IN: state-tables
   5
   6 TUPLE: table rows columns start-state final-states ;
   7 TUPLE: entry row-key column-key value ;
   8
   9 GENERIC: add-entry ( entry table -- )
  10
  11 : make-table ( class -- obj )
  12     new
  13         H{ } clone >>rows
  14         H{ } clone >>columns
  15         H{ } clone >>final-states ;
  16
  17 : <table> ( -- obj )
  18     table make-table ;
  19
  20 C: <entry> entry
  21
  22 : (add-row) ( row-key table -- row )
  23     2dup rows>> at* [
  24         2nip
  25     ] [
  26         drop H{ } clone [ -rot rows>> set-at ] keep
  27     ] if ;
  28
  29 : add-row ( row-key table -- )
  30     (add-row) drop ;
  31
  32 : add-column ( column-key table -- )
  33     t -rot columns>> set-at ;
  34
  35 : set-row ( row row-key table -- )
  36     rows>> set-at ;
  37
  38 : lookup-row ( row-key table -- row/f ? )
  39     rows>> at* ;
  40
  41 : row-exists? ( row-key table -- ? )
  42     lookup-row nip ;
  43
  44 : lookup-column ( column-key table -- column/f ? )
  45     columns>> at* ;
  46
  47 : column-exists? ( column-key table -- ? )
  48     lookup-column nip ;
  49
  50 ERROR: no-row key ;
  51 ERROR: no-column key ;
  52
  53 : get-row ( row-key table -- row )
  54     dupd lookup-row [
  55         nip
  56     ] [
  57         drop no-row
  58     ] if ;
  59
  60 : get-column ( column-key table -- column )
  61     dupd lookup-column [
  62         nip
  63     ] [
  64         drop no-column
  65     ] if ;
  66
  67 : get-entry ( row-key column-key table -- obj ? )
  68     swapd lookup-row [
  69         at*
  70     ] [
  71         2drop f f
  72     ] if ;
  73
  74 : (set-entry) ( entry table -- value column-key row )
  75     [ >r column-key>> r> add-column ] 2keep
  76     dupd >r row-key>> r> (add-row)
  77     >r [ value>> ] keep column-key>> r> ;
  78
  79 : set-entry ( entry table -- )
  80     (set-entry) set-at ;
  81
  82 : delete-entry ( entry table -- )
  83     >r [ column-key>> ] [ row-key>> ] bi r>
  84     lookup-row [ delete-at ] [ 2drop ] if ;
  85
  86 : swap-rows ( row-key1 row-key2 table -- )
  87     [ tuck get-row >r get-row r> ] 3keep
  88     >r >r rot r> r> [ set-row ] keep set-row ;
  89
  90 : member?* ( obj obj -- bool )
  91     2dup = [ 2drop t ] [ member? ] if ;
  92
  93 : find-by-column ( column-key data table -- seq )
  94     swapd 2dup lookup-column 2drop
  95     [
  96         rows>> [
  97             pick swap at* [
  98                 >r pick r> member?* [ , ] [ drop ] if
  99             ] [
 100                 2drop
 101             ] if
 102         ] assoc-each
 103     ] { } make 2nip ;
 104
 105
 106 TUPLE: vector-table < table ;
 107 : <vector-table> ( -- obj )
 108     vector-table make-table ;
 109
 110 : add-hash-vector ( value key hash -- )
 111     2dup at* [
 112         dup vector? [
 113             2nip push
 114         ] [
 115             V{ } clone [ push ] keep
 116             -rot >r >r [ push ] keep r> r> set-at
 117         ] if
 118     ] [
 119         drop set-at
 120     ] if ;
 121
 122 M: vector-table add-entry ( entry table -- )
 123     (set-entry) add-hash-vector ;