diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index fa10fff01c..7d5f976909 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ; +USING: accessors db.tuples kernel new-slots semantic-db +semantic-db.relations sorting sequences sequences.deep ; IN: semantic-db.hierarchy TUPLE: tree id children ; @@ -33,6 +34,9 @@ C: tree : get-node-hierarchy ( node-id -- tree ) dup children [ get-node-hierarchy ] map ; +: uniq ( sorted-seq -- seq ) + f swap [ tuck = not ] subset nip ; + : (get-root-nodes) ( node-id -- root-nodes/node-id ) dup parents dup empty? [ drop @@ -41,4 +45,4 @@ C: tree ] if ; : get-root-nodes ( node-id -- root-nodes ) - (get-root-nodes) flatten ; + (get-root-nodes) flatten natural-sort uniq ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 01476a145a..6c2c4d3e9e 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,18 +1,27 @@ -USING: accessors arrays db db.sqlite db.tuples kernel math namespaces -semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations -sequences tools.test tools.walker ; +USING: accessors arrays continuations db db.sqlite db.tuples io.files +kernel math namespaces semantic-db semantic-db.context +semantic-db.hierarchy semantic-db.relations sequences tools.test +tools.walker ; IN: semantic-db.tests -[ +: db-path "semantic-db-test.db" temp-file ; +: test-db db-path sqlite-db ; +: delete-db [ db-path delete-file ] ignore-errors ; + +delete-db + +test-db [ create-node-table create-arc-table [ 1 ] [ "first node" create-node* ] unit-test [ 2 ] [ "second node" create-node* ] unit-test [ 3 ] [ "third node" create-node* ] unit-test [ 4 ] [ f create-node* ] unit-test [ 5 ] [ 1 2 3 create-arc* ] unit-test -] with-tmp-sqlite +] with-db -[ +delete-db + +test-db [ init-semantic-db "test content" create-context* [ [ 4 ] [ context ] unit-test @@ -35,10 +44,12 @@ IN: semantic-db.tests ! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test ! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test ! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test -] with-tmp-sqlite +] with-db + +delete-db ! test hierarchy -[ +test-db [ init-semantic-db "family tree" create-context* [ "adam" create-node* "adam" set @@ -52,7 +63,9 @@ IN: semantic-db.tests [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test - [ { "adam" "eve" } ] [ "charlie" get break get-root-nodes [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map ] unit-test [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test ] with-context -] with-tmp-sqlite +] with-db + +delete-db diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index a48048f152..e8075c016d 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -86,3 +86,4 @@ arc "arc" #! quot1 ( x y -- z/f ) finds an existing z #! quot2 ( x y -- z ) creates a new z if quot1 returns f >r >r 2dup r> call [ 2nip ] r> if* ; +