state-tables vocab is no longer necessary
Doug Coleman
parent
e62a558cf4
commit
799f761bef
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
USING: kernel state-tables tools.test ;
|
||||
IN: state-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 } }
|
||||
f
|
||||
H{ }
|
||||
}
|
||||
] [ 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-entry
|
||||
"a" "c" "r" <entry> over add-entry
|
||||
"a" "o" "y" <entry> over add-entry
|
||||
"a" "l" "x" <entry> over add-entry
|
||||
"b" "o" "y" <entry> over add-entry
|
||||
"b" "l" "x" <entry> over add-entry
|
||||
"b" "s" "u" <entry> over add-entry ;
|
||||
|
||||
[
|
||||
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 } }
|
||||
f
|
||||
H{ }
|
||||
}
|
||||
] [ vector-test-table ] unit-test
|
||||
|
||||
|
|
@ -1,123 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces make 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 ;
|
||||
Loading…
Reference in New Issue