--- /dev/null
+USING: accessors arrays bank calendar kernel math math.functions namespaces tools.test tools.walker ;
+IN: bank.tests
+
+SYMBOL: my-account
+[
+ "Alex's Take Over the World Fund" 0.07 1 2007 11 1 <date> 6101.94 open-account my-account set
+ [ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
+ [ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
+] with-scope
+
+[
+ "Petty Cash" 0.07 1 2006 12 1 <date> 10962.18 open-account my-account set
+ [ 11027 ] [ my-account get 2007 1 2 <date> process-to-date balance>> round >integer ] unit-test
+] with-scope
+
+[
+ "Saving to buy a pony" 0.0725 1 2008 3 3 <date> 11106.24 open-account my-account set
+ [ 8416 ] [
+ my-account get [
+ 2008 3 11 <date> -750 "Need to buy food" <transaction> ,
+ 2008 3 25 <date> -500 "Going to a party" <transaction> ,
+ 2008 4 8 <date> -800 "Losing interest in the pony..." <transaction> ,
+ 2008 4 8 <date> -700 "Buying a rocking horse" <transaction> ,
+ ] { } make inserting-transactions balance>> round >integer
+ ] unit-test
+] with-scope
+
+[
+ [ 6781 ] [
+ "..." 0.07 1 2007 4 10 <date> 4398.50 open-account
+ 2007 10 26 <date> 2000 "..." <transaction> 1array inserting-transactions
+ 2008 4 10 <date> process-to-date dup balance>> swap unpaid-interest>> + round >integer
+ ] unit-test
+] with-scope
--- /dev/null
+USING: accessors calendar kernel math money sequences ;
+IN: bank
+
+TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ;
+
+: <account> ( name interest-rate interest-payment-day opening-date -- account )
+ V{ } clone 0 pick account construct-boa ;
+
+TUPLE: transaction date amount description ;
+C: <transaction> transaction
+
+: >>transaction ( account transaction -- account )
+ over transactions>> push ;
+
+: total ( transactions -- balance )
+ 0 [ amount>> + ] reduce ;
+
+: balance>> ( account -- balance ) transactions>> total ;
+
+: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
+ >r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
+
+: daily-rate ( yearly-rate day -- daily-rate )
+ days-in-year / ;
+
+: daily-rate>> ( account date -- rate )
+ [ interest-rate>> ] dip daily-rate ;
+
+: before? ( date date -- ? ) <=> 0 < ;
+
+: transactions-on-date ( account date -- transactions )
+ [ before? ] curry subset ;
+
+: balance-on-date ( account date -- balance )
+ transactions-on-date total ;
+
+: pay-interest ( account date -- )
+ over unpaid-interest>> "Interest Credit" <transaction>
+ >>transaction 0 >>unpaid-interest drop ;
+
+: interest-payment-day? ( account date -- ? )
+ day>> swap interest-payment-day>> = ;
+
+: ?pay-interest ( account date -- )
+ 2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
+
+: unpaid-interest+ ( account amount -- account )
+ over unpaid-interest>> + >>unpaid-interest ;
+
+: accumulate-interest ( account date -- )
+ [ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
+ >>interest-last-paid drop ;
+
+: process-day ( account date -- )
+ 2dup accumulate-interest ?pay-interest ;
+
+: each-day ( quot start end -- )
+ 2dup before? [
+ >r dup >r over >r swap call r> r> 1 days time+ r> each-day
+ ] [
+ 3drop
+ ] if ;
+
+: process-to-date ( account date -- account )
+ over interest-last-paid>> 1 days time+
+ [ dupd process-day ] spin each-day ;
+
+: inserting-transactions ( account transactions -- account )
+ [ [ date>> process-to-date ] keep >>transaction ] each ;
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces semantic-db ;
-IN: semantic-db.context
-
-: create-context* ( context-name -- context-id ) create-node* ;
-: create-context ( context-name -- ) create-context* drop ;
-
-: context ( -- context-id )
- \ context get ;
-
-: set-context ( context-id -- )
- \ context set ;
-
-: with-context ( context-id quot -- )
- >r \ context r> with-variable ;
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples hashtables kernel sets
-semantic-db semantic-db.relations sequences sequences.deep ;
-IN: semantic-db.hierarchy
-
-TUPLE: tree id children ;
-C: <tree> tree
-
-: has-parent-relation ( -- relation-id )
- "has parent" relation-id ;
-
-: parent-child* ( parent child -- arc-id )
- has-parent-relation spin create-arc* ;
-
-: parent-child ( parent child -- )
- parent-child* drop ;
-
-: un-parent-child ( parent child -- )
- has-parent-relation spin <arc> select-tuples [ id>> delete-arc ] each ;
-
-: child-arcs ( node-id -- child-arcs )
- has-parent-relation f rot <arc> select-tuples ;
-
-: children ( node-id -- children )
- child-arcs [ subject>> ] map ;
-
-: parent-arcs ( node-id -- parent-arcs )
- has-parent-relation swap f <arc> select-tuples ;
-
-: parents ( node-id -- parents )
- parent-arcs [ object>> ] map ;
-
-: get-node-hierarchy ( node-id -- tree )
- dup children [ get-node-hierarchy ] map <tree> ;
-
-: (get-root-nodes) ( node-id -- root-nodes/node-id )
- dup parents dup empty? [
- drop
- ] [
- nip [ (get-root-nodes) ] map
- ] if ;
-
-: get-root-nodes ( node-id -- root-nodes )
- (get-root-nodes) flatten prune ;
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: db.types kernel namespaces semantic-db semantic-db.context
-sequences.lib ;
-IN: semantic-db.relations
-
-! relations:
-! - have a context in context 'semantic-db'
-
-: create-relation* ( context-id relation-name -- relation-id )
- create-node* tuck has-context-relation spin create-arc ;
-
-: create-relation ( context-id relation-name -- )
- create-relation* drop ;
-
-: get-relation ( context-id relation-name -- relation-id/f )
- [
- ":name" TEXT param ,
- ":context" INTEGER param ,
- has-context-relation ":has_context" INTEGER param ,
- ] { } make
- "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context"
- single-int-results ?first ;
-
-: relation-id ( relation-name -- relation-id )
- context swap [ get-relation ] [ create-relation* ] ensure2 ;
-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 sorting tools.test
+USING: accessors arrays continuations db db.sqlite db.tuples io.files
+kernel math namespaces semantic-db sequences sorting tools.test
tools.walker ;
IN: semantic-db.tests
+SYMBOL: context
+
: 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-db
-
-delete-db
-
-test-db [
- init-semantic-db
- "test content" create-context* [
- [ 4 ] [ context ] unit-test
- [ 5 ] [ context "is test content" create-relation* ] unit-test
- [ 5 ] [ context "is test content" get-relation ] unit-test
- [ 5 ] [ "is test content" relation-id ] unit-test
- [ 7 ] [ "has parent" relation-id ] unit-test
- [ 7 ] [ "has parent" relation-id ] unit-test
- [ "has parent" ] [ "has parent" relation-id node-content ] unit-test
- [ "test content" ] [ context node-content ] unit-test
- ] with-context
- ! type-type 1array [ "type" ensure-type ] unit-test
- ! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
- ! [ 1 ] [ type-type select-node-of-type ] unit-test
- ! [ t ] [ "content" ensure-type integer? ] unit-test
- ! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test
- ! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test
- ! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test
- ! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test
- ! [ 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-db
+ node create-table arc create-table
+ [ 1 ] [ "first node" create-node id>> ] unit-test
+ [ 2 ] [ "second node" create-node id>> ] unit-test
+ [ 3 ] [ "third node" create-node id>> ] unit-test
+ [ 4 ] [ f create-node id>> ] unit-test
+ [ ] [ 1 f <node> 2 f <node> 3 f <node> create-arc ] unit-test
+] with-db delete-db
-delete-db
-
-! test hierarchy
-test-db [
- init-semantic-db
- "family tree" create-context* [
- "adam" create-node* "adam" set
- "eve" create-node* "eve" set
- "bob" create-node* "bob" set
- "fran" create-node* "fran" set
- "charlie" create-node* "charlie" set
- "gertrude" create-node* "gertrude" set
- [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
- { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] bi@ parent-child ] each
- [ { "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 get-root-nodes [ node-content ] map natural-sort >array ] unit-test
- [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
- ] with-context
-] with-db
-
-delete-db
+ test-db [
+ init-semantic-db
+ "test content" create-context context set
+ [ T{ node f 3 "test content" } ] [ context get ] unit-test
+ [ T{ node f 4 "is test content" } ] [ "is test content" context get create-relation ] unit-test
+ [ T{ node f 4 "is test content" } ] [ "is test content" context get get-relation ] unit-test
+ [ T{ node f 4 "is test content" } ] [ "is test content" context get ensure-relation ] unit-test
+ [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
+ [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
+ [ "has parent" ] [ "has parent" context get ensure-relation node-content ] unit-test
+ [ "test content" ] [ context get node-content ] unit-test
+ ] with-db delete-db
+
+ ! "test1" "test1-relation-id-word" f f f f <relation-definition> define-relation
+ ! "test2" t t t t t <relation-definition> define-relation
+ RELATION: test3
+ test-db [
+ init-semantic-db
+ ! [ T{ node f 3 "test1" } ] [ test1-relation-id-word ] unit-test
+ ! [ T{ node f 4 "test2" } ] [ test2-relation ] unit-test
+ [ T{ node f 4 "test3" } ] [ test3-relation ] unit-test
+ ] with-db delete-db
+
+ ! test hierarchy
+ RELATION: has-parent
+ test-db [
+ init-semantic-db
+ "adam" create-node "adam" set
+ "eve" create-node "eve" set
+ "bob" create-node "bob" set
+ "fran" create-node "fran" set
+ "charlie" create-node "charlie" set
+ "gertrude" create-node "gertrude" set
+ [ ] [ "bob" get "adam" get has-parent ] unit-test
+ { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] bi@ has-parent ] each
+ [ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test
+ [ { "adam" "eve" } ] [ "bob" get has-parent-relation parents [ node-content ] map ] unit-test
+ [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get-node-tree-s dup node>> node-content swap children>> [ node>> node-content ] map ] unit-test
+ [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get-root-nodes [ node-content ] map natural-sort >array ] unit-test
+ [ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation parents [ node-content ] map ] unit-test
+ [ { "adam" "eve" } ] [ has-parent-relation ultimate-objects node-results [ node-content ] map ] unit-test
+ [ { "fran" "gertrude" } ] [ has-parent-relation ultimate-subjects node-results [ node-content ] map ] unit-test
+ ] with-db delete-db
+
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ;
+USING: accessors arrays combinators combinators.cleave combinators.lib
+continuations db db.tuples db.types db.sqlite hashtables kernel math
+math.parser namespaces parser sequences sequences.deep
+sequences.lib strings words ;
IN: semantic-db
TUPLE: node id content ;
-: <node> ( content -- node )
- node new swap >>content ;
-
-: <id-node> ( id -- node )
- node new swap >>id ;
+C: <node> node
node "node"
{
{ "content" "content" TEXT }
} define-persistent
-: create-node-table ( -- )
- node create-table ;
-
-: delete-node ( node-id -- )
- <id-node> delete-tuple ;
+: delete-node ( node -- ) delete-tuple ;
+: create-node ( content -- node ) f swap <node> dup insert-tuple ;
+: load-node ( id -- node ) f <node> select-tuple ;
-: create-node* ( str -- node-id )
- <node> dup insert-tuple id>> ;
+: node-content ( node -- content )
+ dup content>> [ nip ] [ select-tuple content>> ] if* ;
-: create-node ( str -- )
- create-node* drop ;
+: node= ( node node -- ? ) [ id>> ] bi@ = ;
-: node-content ( id -- str )
- f <node> swap >>id select-tuple content>> ;
+! TODO: get rid of arc id and write our own sql
+TUPLE: arc id subject object relation ;
-TUPLE: arc id relation subject object ;
-
-: <arc> ( relation subject object -- arc )
- arc new swap >>object swap >>subject swap >>relation ;
+: <arc> ( subject object relation -- arc )
+ arc construct-empty swap >>relation swap >>object swap >>subject ;
: <id-arc> ( id -- arc )
arc new swap >>id ;
-: insert-arc ( arc -- )
- f <node> dup insert-tuple id>> >>id insert-tuple ;
+: delete-arc ( arc -- ) delete-tuple ;
+
+: create-arc ( subject object relation -- )
+ [ id>> ] 3apply <arc> insert-tuple ;
+
+: nodes>arc ( subject object relation -- arc )
+ [ [ id>> ] [ f ] if* ] 3apply <arc> ;
+
+: select-arcs ( subject object relation -- arcs )
+ nodes>arc select-tuples ;
+
+: has-arc? ( subject object relation -- ? )
+ select-arcs length 0 > ;
-: delete-arc ( arc-id -- )
- dup delete-node <id-arc> delete-tuple ;
+: select-arc-subjects ( subject object relation -- subjects )
+ select-arcs [ subject>> f <node> ] map ;
-: create-arc* ( relation subject object -- arc-id )
- <arc> dup insert-arc id>> ;
+: select-arc-subject ( subject object relation -- subject )
+ select-arcs ?first [ subject>> f <node> ] [ f ] if* ;
-: create-arc ( relation subject object -- )
- create-arc* drop ;
+: select-subjects ( object relation -- subjects )
+ f -rot select-arc-subjects ;
+
+: select-subject ( object relation -- subject )
+ f -rot select-arc-subject ;
+
+: select-arc-objects ( subject object relation -- objects )
+ select-arcs [ object>> f <node> ] map ;
+
+: select-arc-object ( subject object relation -- object )
+ select-arcs ?first [ object>> f <node> ] [ f ] if* ;
+
+: select-objects ( subject relation -- objects )
+ f swap select-arc-objects ;
+
+: select-object ( subject relation -- object )
+ f swap select-arc-object ;
+
+: delete-arcs ( subject object relation -- )
+ select-arcs [ delete-arc ] each ;
arc "arc"
{
- { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
+ { "id" "id" +native-id+ +autoincrement+ }
{ "relation" "relation" INTEGER +not-null+ }
{ "subject" "subject" INTEGER +not-null+ }
{ "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 ;
+
+! db utilities
+: results ( bindings sql -- array )
+ f f <simple-statement> [ do-bound-query ] with-disposal ;
+
+: node-result ( result -- node )
+ dup first string>number swap second <node> ;
+
+: ?1node-result ( results -- node )
+ ?first [ node-result ] [ f ] if* ;
+
+: node-results ( results -- nodes )
+ [ node-result ] map ;
: param ( value key type -- param )
swapd <sqlite-low-level-binding> ;
-: single-int-results ( bindings sql -- array )
- f f <simple-statement> [ 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> relation-definition
+
+<PRIVATE
+
+: default-word-name ( relate-word-name word-type -- word-name )
+ {
+ { "relate" [ ] }
+ { "id-word" [ "-relation" append ] }
+ { "unrelate" [ "!" swap append ] }
+ { "related?" [ "?" append ] }
+ { "subjects" [ "-subjects" append ] }
+ { "objects" [ "-objects" append ] }
+ } case ;
+
+: choose-word-name ( relation-definition given-word-name word-type -- word-name )
+ over string? [
+ drop nip
+ ] [
+ nip [ relate>> ] 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 <relation-definition> define-relation ; parsing
+
+! hierarchy
+TUPLE: node-tree node children ;
+C: <node-tree> 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 <node-tree> ;
+
+! : get-node-tree ( node has-parent-relation -- node-tree )
+! 2dup children >r [ get-node-tree ] curry r> swap map <node-tree> ;
+: 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 ;
--- /dev/null
+USING: html kernel semantic-db tangle.html tools.test ;
+IN: tangle.html.tests
+
+[ "test" ] [ "test" >html ] unit-test
+[ "<ul><li>An Item</li></ul>" ] [ { "An Item" } <ulist> >html ] unit-test
+[ "<ul><li>One</li><li>Two</li><li>Three, ah ah ah</li></ul>" ] [ { "One" "Two" "Three, ah ah ah" } <ulist> >html ] unit-test
+[ "<a href='foo/bar'>some link</a>" ] [ "foo/bar" "some link" <link> >html ] unit-test
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors html html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
+IN: tangle.html
+
+TUPLE: element attributes ;
+
+TUPLE: ulist < element items ;
+: <ulist> ( items -- element )
+ H{ } clone swap ulist construct-boa ;
+
+TUPLE: link < element href text ;
+: <link> ( href text -- element )
+ H{ } clone -rot link construct-boa ;
+
+GENERIC: >html ( element -- str )
+
+M: string >html ( str -- str ) ;
+
+M: link >html ( link -- str )
+ [ <a dup href>> =href a> text>> write </a> ] with-string-writer ;
+
+M: node >html ( node -- str )
+ dup node>path [
+ swap node-content <link> >html
+ ] [
+ node-content
+ ] if* ;
+
+M: ulist >html ( ulist -- str )
+ [
+ <ul> items>> [ <li> >html write </li> ] each </ul>
+ ] with-string-writer ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel semantic-db sequences tangle.html ;
+IN: tangle.menu
+
+RELATION: subitem-of
+RELATION: before
+
+: get-menus ( -- nodes )
+ subitem-of-relation ultimate-objects node-results ;
+
+: get-menu ( name -- node )
+ get-menus [ node-content = ] with find nip ;
+
+: ensure-menu ( name -- node )
+ dup get-menu [ nip ] [ create-node ] if* ;
+
+: load-menu ( name -- menu )
+ get-menu subitem-of-relation get-node-tree-s ;
+
+: menu>ulist ( menu -- str ) children>> <ulist> ;
+: menu>html ( menu -- str ) menu>ulist >html ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel semantic-db sequences sequences.lib ;
+IN: tangle.page
+
+RELATION: has-abbreviation
+RELATION: has-content
+RELATION: has-subsection
+RELATION: before
+RELATION: authored-by
+RELATION: authored-on
+
+TUPLE: page name abbreviation author created content ;
+C: <page> page
+
+: load-page-content ( node -- content )
+ has-content-objects [ node-content ] map concat ;
+
+: load-page ( node -- page )
+ dup [ has-abbreviation-objects ?first ] keep
+ [ authored-by-objects ?first ] keep
+ [ authored-on-objects ?first ] keep
+ load-page-content <page> ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel semantic-db sequences sequences.lib splitting ;
+IN: tangle.path
+
+RELATION: has-filename
+RELATION: in-directory
+
+: create-root ( -- node ) "" create-node ;
+
+: get-root ( -- node )
+ in-directory-relation ultimate-objects ?1node-result ;
+
+: ensure-root ( -- node ) get-root [ create-root ] unless* ;
+
+: create-file ( parent name -- node )
+ create-node swap dupd in-directory ;
+
+: files-in-directory ( node -- nodes ) in-directory-subjects ;
+
+: file-in-directory ( name node -- node )
+ in-directory-relation subjects-with-cor ?1node-result ;
+
+: parent-directory ( file-node -- dir-node )
+ in-directory-objects ?first ;
+
+: (path>node) ( node name -- node )
+ swap [ file-in-directory ] [ drop f ] if* ;
+
+USE: tools.walker
+: path>node ( path -- node )
+ "/" split ensure-root swap [ (path>node) ] each ;
+
+: (node>path) ( root seq node -- seq )
+ pick over node= [
+ drop nip
+ ] [
+ dup node-content pick push
+ parent-directory [
+ (node>path)
+ ] [
+ 2drop f
+ ] if*
+ ] if ;
+
+: node>path* ( root node -- path )
+ V{ } clone swap (node>path) dup empty?
+ [ drop f ] [ <reversed> "/" join ] if ;
+
+: node>path ( node -- path )
+ ensure-root swap node>path* ;
--- /dev/null
+USING: accessors arrays continuations db db.sqlite io.files kernel semantic-db sequences tangle tangle.html tangle.menu tangle.page tangle.path tools.test tools.walker tuple-syntax ;
+IN: tangle.tests
+
+: db-path "tangle-test.db" temp-file ;
+: test-db db-path sqlite-db ;
+: delete-db [ db-path delete-file ] ignore-errors ;
+
+: test-tangle ( -- )
+ ensure-root "foo" create-file "bar" create-file "pluck_eggs" create-file
+ "How to Pluck Eggs" create-node swap has-filename
+ "Main Menu" ensure-menu "home" create-node swap subitem-of ;
+
+test-db [
+ init-semantic-db test-tangle
+ [ "pluck_eggs" ] [ "foo/bar/pluck_eggs" path>node [ node-content ] when* ] unit-test
+ [ "How to Pluck Eggs" ] [ "foo/bar/pluck_eggs" path>node [ has-filename-subjects first node-content ] when* ] unit-test
+ [ "foo/bar/pluck_eggs" ] [ "foo/bar/pluck_eggs" path>node node>path ] unit-test
+ [ f ] [ TUPLE{ node id: 666 content: "some content" } parent-directory ] unit-test
+ [ f ] [ TUPLE{ node id: 666 content: "some content" } node>path ] unit-test
+ [ "Main Menu" ] [ "Main Menu" ensure-menu node-content ] unit-test
+ [ t ] [ "Main Menu" ensure-menu "Main Menu" ensure-menu node= ] unit-test
+ [ "Main Menu" { "home" } ] [ "Main Menu" load-menu dup node>> node-content swap children>> [ node>> node-content ] map >array ] unit-test
+ [ { "home" } ] [ "Main Menu" load-menu menu>ulist items>> [ node>> node-content ] map >array ] unit-test
+ [ f ] [ TUPLE{ node id: 666 content: "node text" } node>path ] unit-test
+ [ "node text" ] [ TUPLE{ node id: 666 content: "node text" } >html ] unit-test
+] with-db delete-db
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs db db.sqlite db.postgresql http.server io kernel namespaces semantic-db sequences strings ;
+IN: tangle
+
+GENERIC: render* ( content templater -- output )
+GENERIC: render ( content templater -- )
+
+TUPLE: echo-template ;
+C: <echo-template> echo-template
+
+M: echo-template render* drop ;
+! METHOD: render* { string echo-template } drop ;
+M: object render render* write ;
+
+TUPLE: tangle db templater ;
+C: <tangle> tangle
+
+TUPLE: sqlite-tangle ;
+TUPLE: postgres-tangle ;
+
+: make-tangle ( db templater type -- tangle )
+ construct-empty [ <tangle> ] dip tuck set-delegate ;
+
+: <sqlite-tangle> ( db templater -- tangle ) sqlite-tangle make-tangle ;
+: <postgres-tangle> ( db templater -- tangle ) postgres-tangle make-tangle ;
+
+: with-tangle ( tangle quot -- )
+ [ db>> ] dip with-db ;
+
+: init-db ( tangle -- tangle )
+ dup [ init-semantic-db ] with-tangle ;
+
+GENERIC# new-db 1 ( tangle obj -- tangle )
+M: sqlite-tangle new-db ( tangle filename -- tangle )
+ sqlite-db >>db init-db ;
+M: postgres-tangle new-db ( tangle args -- tangle )
+ postgresql-db >>db init-db ;
+
+TUPLE: node-responder tangle ;
+C: <node-responder> node-responder
+
+M: node-responder call-responder ( path responder -- response )
+ "text/plain" <content> nip request-params
+ [ "node-id" swap at* [ >>body ] [ drop ] if ] when* nip ;
+
+: test-tangle ( -- )
+ f f <sqlite-tangle> <node-responder> main-responder set ;
+
projects / factor.git / commitdiff