required by regexp4

extra/state-tables/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/state-tables/state-tables-tests.factor

@@ -0,0 +1,49 @@
+USING: kernel tables tools.test ;
+IN: tables.tests
+
+: test-table
+    <table>
+    "a" "c" "z" <entry> over set-entry
+    "a" "o" "y" <entry> over set-entry
+    "a" "l" "x" <entry> over set-entry
+    "b" "o" "y" <entry> over set-entry
+    "b" "l" "x" <entry> over set-entry
+    "b" "s" "u" <entry> over set-entry ;
+
+[
+    T{ table f
+    H{ 
+        { "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
+        { "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
+    }
+    H{ { "l" t } { "s" t } { "c" t } { "o" t } } }
+] [ test-table ] unit-test
+
+[ "x" t ] [ "a" "l" test-table get-entry ] unit-test
+[ "har" t ] [
+    "a" "z" "har" <entry> test-table [ set-entry ] keep
+    >r "a" "z" r> get-entry
+] unit-test
+
+: vector-test-table
+    <vector-table>
+    "a" "c" "z" <entry> over add-value
+    "a" "c" "r" <entry> over add-value
+    "a" "o" "y" <entry> over add-value
+    "a" "l" "x" <entry> over add-value
+    "b" "o" "y" <entry> over add-value
+    "b" "l" "x" <entry> over add-value
+    "b" "s" "u" <entry> over add-value ;
+
+[
+T{ vector-table f
+    H{ 
+        { "a"
+            H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
+        { "b"
+            H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
+    }
+    H{ { "l" t } { "s" t } { "c" t } { "o" t } }
+}
+] [ vector-test-table ] unit-test
+

extra/state-tables/state-tables.factor

@@ -0,0 +1,123 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces sequences vectors assocs accessors ;
+IN: state-tables
+
+TUPLE: table rows columns start-state final-states ;
+TUPLE: entry row-key column-key value ;
+
+GENERIC: add-entry ( entry table -- )
+
+: make-table ( class -- obj )
+    new
+        H{ } clone >>rows
+        H{ } clone >>columns
+        H{ } clone >>final-states ;
+
+: <table> ( -- obj )
+    table make-table ;
+
+C: <entry> entry
+
+: (add-row) ( row-key table -- row )
+    2dup rows>> at* [
+        2nip
+    ] [
+        drop H{ } clone [ -rot rows>> set-at ] keep
+    ] if ;
+
+: add-row ( row-key table -- )
+    (add-row) drop ;
+
+: add-column ( column-key table -- )
+    t -rot columns>> set-at ;
+
+: set-row ( row row-key table -- )
+    rows>> set-at ;
+
+: lookup-row ( row-key table -- row/f ? )
+    rows>> at* ;
+
+: row-exists? ( row-key table -- ? )
+    lookup-row nip ;
+
+: lookup-column ( column-key table -- column/f ? )
+    columns>> at* ;
+
+: column-exists? ( column-key table -- ? )
+    lookup-column nip ;
+
+ERROR: no-row key ;
+ERROR: no-column key ;
+
+: get-row ( row-key table -- row )
+    dupd lookup-row [
+        nip
+    ] [
+        drop no-row
+    ] if ;
+
+: get-column ( column-key table -- column )
+    dupd lookup-column [
+        nip
+    ] [
+        drop no-column
+    ] if ;
+
+: get-entry ( row-key column-key table -- obj ? )
+    swapd lookup-row [
+        at*
+    ] [
+        2drop f f
+    ] if ;
+
+: (set-entry) ( entry table -- value column-key row )
+    [ >r column-key>> r> add-column ] 2keep
+    dupd >r row-key>> r> (add-row)
+    >r [ value>> ] keep column-key>> r> ;
+
+: set-entry ( entry table -- )
+    (set-entry) set-at ;
+
+: delete-entry ( entry table -- )
+    >r [ column-key>> ] [ row-key>> ] bi r>
+    lookup-row [ delete-at ] [ 2drop ] if ;
+
+: swap-rows ( row-key1 row-key2 table -- )
+    [ tuck get-row >r get-row r> ] 3keep
+    >r >r rot r> r> [ set-row ] keep set-row ;
+
+: member?* ( obj obj -- bool )
+    2dup = [ 2drop t ] [ member? ] if ;
+
+: find-by-column ( column-key data table -- seq )
+    swapd 2dup lookup-column 2drop 
+    [
+        rows>> [
+            pick swap at* [ 
+                >r pick r> member?* [ , ] [ drop ] if
+            ] [ 
+                2drop
+            ] if 
+        ] assoc-each
+    ] { } make 2nip ;
+
+
+TUPLE: vector-table < table ;
+: <vector-table> ( -- obj )
+    vector-table make-table ;
+
+: add-hash-vector ( value key hash -- )
+    2dup at* [
+        dup vector? [
+            2nip push
+        ] [
+            V{ } clone [ push ] keep
+            -rot >r >r [ push ] keep r> r> set-at
+        ] if
+    ] [
+        drop set-at
+    ] if ;
+ 
+M: vector-table add-entry ( entry table -- )
+    (set-entry) add-hash-vector ;