From 229e9835fb51150542fc973a283beeded3fe4c7c Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 8 Mar 2008 10:06:56 +1100 Subject: [PATCH] deleting old semantic-db code --- extra/semantic-db/db/db-tests.factor | 26 --- extra/semantic-db/db/db.factor | 281 --------------------------- 2 files changed, 307 deletions(-) delete mode 100644 extra/semantic-db/db/db-tests.factor delete mode 100644 extra/semantic-db/db/db.factor diff --git a/extra/semantic-db/db/db-tests.factor b/extra/semantic-db/db/db-tests.factor deleted file mode 100644 index 303ec658a0..0000000000 --- a/extra/semantic-db/db/db-tests.factor +++ /dev/null @@ -1,26 +0,0 @@ -USING: io.files kernel namespaces semantic-db.db semantic-db.db.private sqlite tools.test ; -IN: temporary - -[ "n.id" ] [ "id" "n" [ 0 column-text ] field-sql ] unit-test -[ "select n.id from nodes n where n.content = :content" ] [ - - "id" "n" [ 0 column-text ] over add-field - "nodes n" over add-table - "n.content = :content" over add-condition - query-sql -] unit-test - -[ - 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 - [ "first node" ] [ 1 node-content ] unit-test - [ 5 ] [ 1 2 3 create-arc ] unit-test - [ { { 1 2 3 } } ] [ 2 node-arcs ] unit-test - [ { { 1 2 3 } } ] [ 3 node-arcs ] unit-test - [ { { 3 1 } } ] [ 2 node-subject-arcs ] unit-test - [ { { 2 1 } } ] [ 3 node-object-arcs ] unit-test -] -with-tmp-db diff --git a/extra/semantic-db/db/db.factor b/extra/semantic-db/db/db.factor deleted file mode 100644 index 52271bfda8..0000000000 --- a/extra/semantic-db/db/db.factor +++ /dev/null @@ -1,281 +0,0 @@ -! Copyright (C) 2007, 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math namespaces new-slots sequences sqlite ; -IN: semantic-db.db - -! sqlite utils -: prepare ( string -- statement ) - db get swap sqlite-prepare ; - -: binding ( statement key val -- statement ) - >r dup integer? [ 1+ ] when dupd r> sqlite-bind-by-name-or-index ; - -GENERIC# bindings 1 ( bindings statement -- statement ) - -M: assoc bindings - swap [ binding ] assoc-each ; - -M: sequence bindings - swap dup length swap [ binding ] 2each ; - -: prepare-with-bindings ( bindings string -- statement ) - prepare bindings ; - -: select-with-bindings ( bindings string quot -- results ) - >r prepare-with-bindings dup r> sqlite-map swap sqlite-finalize ; - -: ignore-and-finalize ( statement -- ) - dup [ drop ] sqlite-each sqlite-finalize ; - -: sql-update ( string -- ) - prepare ignore-and-finalize ; - -: update-with-bindings ( bindings string -- ) - prepare-with-bindings ignore-and-finalize ; - -: 1result ( array -- result ) - #! return the first (and hopefully only) element of the array, or f - dup length zero? [ drop f ] [ first ] if ; - -: (collect-int-columns) ( statement n -- ) - [ dupd column-int , ] each drop ; - -: collect-int-columns ( statement n -- columns ) - [ (collect-int-columns) ] { } make ; - -! queries -TUPLE: field name table retriever ; -C: field - -TUPLE: query fields tables conditions args statement results ; - -: call-field-retrievers ( query - -: ( -- query ) - V{ } clone V{ } clone V{ } clone H{ } clone f f - query construct-boa ; - -: invalidate-query ( query -- query ) - f >>results ; - -: add-field ( field query -- query ) - dup invalidate-query fields>> push ; - -: add-table ( table query -- query ) - dup invalidate-query tables>> push ; - -: add-condition ( condition query -- query ) - tuck invalidate-query conditions>> push ; - -: add-arg ( arg key query -- query ) - [ invalidate-query args>> set-at ] keep ; - -> % CHAR: . , name>> % ] "" make ; - -: fields-sql ( query -- sql ) - fields>> dup length [ - [ field-sql ] map ", " join - ] [ - drop "*" - ] if ; - -: tables-sql ( query -- sql ) - tables>> ", " join ; - -: conditions-sql ( query -- sql ) - conditions>> dup length [ - " and " join "where " swap append - ] [ - drop "" - ] if ; - -: query-sql ( query -- sql ) - [ - "select" , dup fields-sql , dup "from" , tables-sql , conditions-sql , - ] { } make " " join ; - -: prepare-query ( query -- query ) - dup query-sql prepare >>statement ; - -: bind-query ( query -- query ) - dup args>> over statement>> bindings >>statement ; - -: (retrieve) ( statement query -- result ) - fields>> swap [ retriever>> call ] curry each ; - -: retrieve ( query -- query ) - dup statement>> over [ (retrieve) ] curry sqlite-map - swap >>results ; - ! dup query-statement over query-retriever sqlite-map swap >>results ; - -: finalize-query ( query -- query ) - statement>> dup sqlite-finalize f swap >>statement ; - -PRIVATE> - -: run-query ( query -- ) - dup prepare-query dup bind-query dup retrieve finalize-query ; - -: get-results ( query -- results ) - dup results>> [ nip ] [ dup run-query results>> ] if* ; - -! nodes and arcs - -! maybe merge nodes and arcs table, so arcs can be nodes too: -! create table nodes (id integer primary key autoincrement, value none, type integer, subject integer, object integer) -! nodes: -! value: node content -! type: nid of node type -! subject: null -! object: null -! -! arcs: -! value: ordinality, or null -! type: nid of relation -! subject: nid of arc subject -! object: nid of arc object -! -! An alternative layout: -! -! nodes: -! id -! type -! -! content: -! id -! content -! -! arcs: -! id -! relation -! subject -! object -! ordinal -! -! A third alternative. In this, all arcs have an entry in the nodes table, but -! their content is null. No node that isn't an arc can have null content. If an -! arc needs an ordinal, then it can be created as another arc. -! -! nodes: -! id -! content -! -! arcs: -! id -! relation -! subject -! object - -: create-node-table ( -- ) - "create table nodes (id integer primary key autoincrement, content none);" sql-update ; - -: create-arc-table ( -- ) - "create table arcs (id integer, relation integer, subject integer, object integer);" sql-update ; - -: create-node ( content -- id ) - #! if content is f then it is inserted as NULL - [ 1array ] [ drop { } clone ] if* - "insert into nodes (content) values (?);" - update-with-bindings db get sqlite-last-insert-rowid ; - -: create-bootstrap-nodes ( -- ) - { "context" "relation" "is of type" "semantic-db" "is in context" } - [ create-node drop ] each ; - -: context-type 1 ; inline -: relation-type 2 ; inline -: has-type-relation 3 ; inline -: semantic-db-context 4 ; inline -: has-context-relation 5 ; inline - -: create-arc ( relation subject object -- id ) - f create-node -roll 4array - "insert into arcs (id, relation, subject, object) values (?, ?, ?, ?);" - update-with-bindings ; - -: create-bootstrap-arcs ( -- ) - has-type-relation has-type-relation relation-type create-arc drop - has-type-relation semantic-db-context context-type create-arc drop - has-context-relation has-type-relation semantic-db-context create-arc drop - has-type-relation has-context-relation relation-type create-arc drop - has-context-relation has-context-relation semantic-db-context create-arc drop ; - -: init-semantic-db ( -- ) - create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; - -: node-content ( id -- content ) - 1array "select content from nodes where id = ?" [ 0 column-text ] select-with-bindings 1result ; - -: node-arcs ( node-id -- arcs ) - 1array "select id, relation, subject, object from arcs where subject = ?1 or object = ?1;" - [ 4 collect-int-columns ] select-with-bindings ; - -: node-subject-arcs ( node-id -- arcs ) - 1array "select object, relation from arcs where subject = ?;" - [ 2 collect-int-columns ] select-with-bindings ; - -: node-object-arcs ( node-id -- arcs ) - 1array "select subject, relation from arcs where object = ?;" - [ 2 collect-int-columns ] select-with-bindings ; - -: relation-subject-objects ( relation subject -- objects ) - 2array "select object from arcs where relation = ? and subject = ?;" - [ 0 column-int ] select-with-bindings ; - -: relation-object-subjects ( relation object -- subjects ) - 2array "select subject from arcs where relation = ? and object = ?;" - [ 0 column-int ] select-with-bindings ; - -: subject-object-relations ( subject object -- relations ) - 2array "select relation from arcs where subject = ? and object = ?" - [ 0 column-int ] select-with-bindings ; - -: type-and-name-node ( type name -- node ) - has-type-relation 3array - "select n.id from arcs a, nodes n where a.subject = n.id and a.object = ? and n.name = ? and a.relation = ?" - [ 0 column-int ] select-with-bindings 1result ; - -: create-node-of-type ( type name -- node ) - create-node [ has-type-relation -rot create-arc drop ] keep ; - -: ensure-node-of-type ( type name -- node ) - 2dup type-and-name-node [ 2nip ] [ create-node-of-type ] if* ; - -: type-and-name-in-context-node ( context type name -- node ) - - "id" "n" [ 0 column-int ] add-field - "nodes n" add-table - "n.name = :name" add-condition - ":name" add-arg - "arcs a" add-table - "a.relation = :has_type" add-condition - has-type-relation ":has_type" add-arg - "a.subject = n.id" add-condition - "a.object = :type" add-condition - ":type" add-arg - "arcs b" add-table - "b.subject = a.relation" add-condition - "b.relation = :has_context" add-condition - has-context-relation ":has_context" add-arg - "b.object = :context" add-condition - ":context" add-arg - get-results 1result ; - - -! ideas for an api: -! this would work something like jquery, where arcs can be selected according -! to parameters, and the contents of nodes and arcs are retrieved on demand, or -! at the program's convenience. It may be better to do this as a query language. -! TUPLE: node id content ; -! : node-text ( node -- text ) -! dup node-content [ -! nip -! ] [ -! node-id ! now get content from database, save it in node-content, and return it -! ] if* ; -! TUPLE: arc id relation subject object ; -! -! TUPLE: arcs ids relation subject object ;