From: Alex Chapman Date: Wed, 23 Apr 2008 12:30:00 +0000 (+1000) Subject: Merge branch 'master' of http://factorcode.org/git/factor into morse X-Git-Tag: 0.94~3254^2~27 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=2f48f21eaf74b80c56280ba0473a8cb341abc06b Merge branch 'master' of http://factorcode.org/git/factor into morse Conflicts: extra/semantic-db/semantic-db.factor --- 2f48f21eaf74b80c56280ba0473a8cb341abc06b diff --cc extra/semantic-db/semantic-db.factor index dad1dd3919,279ebcf922..51bd94d61c --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@@ -82,200 -59,31 +82,201 @@@ arc "arc { "object" "object" INTEGER +not-null+ } } define-persistent -: create-arc-table ( -- ) - arc create-table ; - : create-bootstrap-nodes ( -- ) - "semantic-db" create-node - "has context" create-node ; + "semantic-db" create-node drop + "has-context" create-node drop ; -: semantic-db-context 1 ; -: has-context-relation 2 ; +: semantic-db-context T{ node f 1 "semantic-db" } ; +: has-context-relation T{ node f 2 "has-context" } ; : create-bootstrap-arcs ( -- ) - has-context-relation has-context-relation semantic-db-context create-arc ; + has-context-relation semantic-db-context has-context-relation create-arc ; : init-semantic-db ( -- ) - create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; + node create-table arc create-table + create-bootstrap-nodes create-bootstrap-arcs ; + - : param ( value key type -- param ) swapd 3array ; - +! db utilities +: results ( bindings sql -- array ) + f f [ do-bound-query ] with-disposal ; + +: node-result ( result -- node ) + dup first string>number swap second ; + +: ?1node-result ( results -- node ) + ?first [ node-result ] [ f ] if* ; + +: node-results ( results -- nodes ) + [ node-result ] map ; + : param ( value key type -- param ) + swapd ; + -: single-int-results ( bindings sql -- array ) - f f [ do-bound-query ] with-disposal - [ first string>number ] map ; +: subjects-with-cor ( content object relation -- sql-results ) + [ id>> ] bi@ + [ + ":relation" INTEGER param , + ":object" INTEGER param , + ":content" TEXT param , + ] { } make + "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.subject and a.relation = :relation and a.object = :object" results ; + +: objects-with-csr ( content subject relation -- sql-results ) + [ id>> ] bi@ + [ + ":relation" INTEGER param , + ":subject" INTEGER param , + ":content" TEXT param , + ] { } make + "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.object and a.relation = :relation and a.subject = :subject" results ; + +: (with-relation) ( content relation -- bindings sql ) + id>> [ ":relation" INTEGER param , ":content" TEXT param , ] { } make + "select distinct n.id, n.content from node n, arc a where n.content = :content and a.relation = :relation" ; + +: subjects-with-relation ( content relation -- sql-results ) + (with-relation) " and a.object = n.id" append results ; + +: objects-with-relation ( content relation -- sql-results ) + (with-relation) " and a.subject = n.id" append results ; + +: (ultimate) ( relation b a -- sql-results ) + [ + "select distinct n.id, n.content from node n, arc a where a.relation = :relation and n.id = a." % % " and n.id not in (select b." % % " from arc b where b.relation = :relation)" % + ] "" make [ id>> ":relation" INTEGER param 1array ] dip results ; + +: ultimate-objects ( relation -- sql-results ) + "subject" "object" (ultimate) ; + +: ultimate-subjects ( relation -- sql-results ) + "object" "subject" (ultimate) ; + +! contexts: +! - a node n is a context iff there exists a relation r such that r has context n +: create-context ( context-name -- context ) create-node ; + +: get-context ( context-name -- context/f ) + has-context-relation subjects-with-relation ?1node-result ; + +: ensure-context ( context-name -- context ) + dup get-context [ + nip + ] [ + create-context + ] if* ; + +! relations: +! - have a context in context 'semantic-db' + +: create-relation ( relation-name context -- relation ) + [ create-node dup ] dip has-context-relation create-arc ; + +: get-relation ( relation-name context -- relation/f ) + has-context-relation subjects-with-cor ?1node-result ; + +: ensure-relation ( relation-name context -- relation ) + 2dup get-relation [ + 2nip + ] [ + create-relation + ] if* ; + +TUPLE: relation-definition relate id-word unrelate related? subjects objects ; +C: relation-definition + +> ] dip default-word-name + ] if ; + +: (define-relation-word) ( id-word word-name definition -- id-word ) + >r create-in over [ execute ] curry r> compose define ; + +: define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word ) + >r >r [ + pick swap r> choose-word-name r> (define-relation-word) + ] [ + r> r> 2drop + ] if* ; + +: define-relation-words ( relation-definition id-word -- ) + over relate>> "relate" [ create-arc ] define-relation-word + over unrelate>> "unrelate" [ delete-arcs ] define-relation-word + over related?>> "related?" [ has-arc? ] define-relation-word + over subjects>> "subjects" [ select-subjects ] define-relation-word + over objects>> "objects" [ select-objects ] define-relation-word + 2drop ; + +: define-id-word ( relation-definition id-word -- ) + [ relate>> ] dip tuck word-vocabulary + [ ensure-context ensure-relation ] 2curry define ; + +: create-id-word ( relation-definition -- id-word ) + dup id-word>> "id-word" choose-word-name create-in ; + +PRIVATE> + +: define-relation ( relation-definition -- ) + dup create-id-word 2dup define-id-word define-relation-words ; + +: RELATION: + scan t t t t t define-relation ; parsing + +! hierarchy +TUPLE: node-tree node children ; +C: node-tree + +: children ( node has-parent-relation -- children ) select-subjects ; +: parents ( node has-parent-relation -- parents ) select-objects ; + +: get-node-tree ( node child-selector -- node-tree ) + 2dup call >r [ get-node-tree ] curry r> swap map ; + +! : get-node-tree ( node has-parent-relation -- node-tree ) +! 2dup children >r [ get-node-tree ] curry r> swap map ; +: get-node-tree-s ( node has-parent-relation -- tree ) + [ select-subjects ] curry get-node-tree ; + +: get-node-tree-o ( node has-child-relation -- tree ) + [ select-objects ] curry get-node-tree ; + +: (get-node-chain) ( node next-selector seq -- seq ) + pick [ + over push >r [ call ] keep r> (get-node-chain) + ] [ + 2nip + ] if* ; + +: get-node-chain ( node next-selector -- seq ) + V{ } clone (get-node-chain) ; + +: get-node-chain-o ( node relation -- seq ) + [ select-object ] curry get-node-chain ; + +: get-node-chain-s ( node relation -- seq ) + [ select-subject ] curry get-node-chain ; + +: (get-root-nodes) ( node has-parent-relation -- root-nodes/node ) + 2dup parents dup empty? [ + 2drop + ] [ + >r nip [ (get-root-nodes) ] curry r> swap map + ] if ; -: ensure2 ( x y quot1 quot2 -- z ) - #! 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* ; +: get-root-nodes ( node has-parent-relation -- root-nodes ) + (get-root-nodes) flatten prune ;