From cf18828cca7bc6f8981f5f5119a9aa7151103541 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 11 Mar 2008 10:38:34 +1100 Subject: [PATCH 01/24] starting bank account stuff --- extra/bank/bank.factor | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 extra/bank/bank.factor diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor new file mode 100644 index 0000000000..c9228bedd5 --- /dev/null +++ b/extra/bank/bank.factor @@ -0,0 +1,33 @@ +USING: accessors calendar kernel money new-slots sequences ; +IN: bank + +MIXIN: policy +TUPLE: simple-policy interest-rate ; +INSTANCE: simple-policy policy +C: simple-policy + +GENERIC: interest-rate ( date account policy -- rate ) +M: simple-policy interest-rate 2nip interest-rate>> ; + +: daily-interest-rate ( date account policy -- rate ) + pick days-in-year >r interest-rate r> / ; + +TUPLE: account name balance transactions ; + +: ( name -- account ) + 0 V{ } clone account construct-boa ; + +TUPLE: transaction date amount description ; + +C: transaction + +: >>transaction ( account transaction -- account ) + over transactions>> push ; + +: open-account ( date opening-balance name -- account ) + >r "Account Opened" >>transaction ; + +: open-account-now ( opening-balance name -- account ) + now -rot open-account ; + + From a7acb16e2002b2f8cb9d77e3753a61aa2d5fb5c0 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sun, 16 Mar 2008 12:41:13 +1100 Subject: [PATCH 02/24] semantic-db: committing latest changes --- extra/semantic-db/context/context.factor | 8 +-- extra/semantic-db/hierarchy/hierarchy.factor | 13 +++-- .../semantic-db/membership/membership.factor | 6 +++ extra/semantic-db/relations/relations.factor | 2 +- extra/semantic-db/semantic-db-tests.factor | 49 +++++++++---------- 5 files changed, 38 insertions(+), 40 deletions(-) create mode 100644 extra/semantic-db/membership/membership.factor diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor index 777c481ebb..9d2e175b5e 100644 --- a/extra/semantic-db/context/context.factor +++ b/extra/semantic-db/context/context.factor @@ -6,11 +6,5 @@ IN: semantic-db.context : create-context* ( context-name -- context-id ) create-node* ; : create-context ( context-name -- ) create-context* drop ; -: context ( -- context-id ) - \ context get ; +SYMBOL: context -: set-context ( context-id -- ) - \ context set ; - -: with-context ( context-id quot -- ) - >r \ context r> with-variable ; diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index be0789ba5e..f180ddb5df 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,32 +1,31 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples hashtables kernel new-slots +USING: accessors db.tuples hashtables kernel namespaces new-slots semantic-db semantic-db.relations sequences sequences.deep ; IN: semantic-db.hierarchy TUPLE: tree id children ; C: tree -: has-parent-relation ( -- relation-id ) - "has parent" relation-id ; +SYMBOL: has-parent-relation : parent-child* ( parent child -- arc-id ) - has-parent-relation spin create-arc* ; + has-parent-relation get spin create-arc* ; : parent-child ( parent child -- ) parent-child* drop ; : un-parent-child ( parent child -- ) - has-parent-relation spin select-tuples [ id>> delete-arc ] each ; + has-parent-relation get spin select-tuples [ id>> delete-arc ] each ; : child-arcs ( node-id -- child-arcs ) - has-parent-relation f rot select-tuples ; + has-parent-relation get f rot select-tuples ; : children ( node-id -- children ) child-arcs [ subject>> ] map ; : parent-arcs ( node-id -- parent-arcs ) - has-parent-relation swap f select-tuples ; + has-parent-relation get swap f select-tuples ; : parents ( node-id -- parents ) parent-arcs [ object>> ] map ; diff --git a/extra/semantic-db/membership/membership.factor b/extra/semantic-db/membership/membership.factor new file mode 100644 index 0000000000..c386922979 --- /dev/null +++ b/extra/semantic-db/membership/membership.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel new-slots semantic-db semantic-db.relations ; +IN: semantic-db.membership + + diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor index 17c335c4ae..58003c9e9d 100644 --- a/extra/semantic-db/relations/relations.factor +++ b/extra/semantic-db/relations/relations.factor @@ -23,4 +23,4 @@ IN: semantic-db.relations single-int-results ?first ; : relation-id ( relation-name -- relation-id ) - context swap [ get-relation ] [ create-relation* ] ensure2 ; + context get swap [ get-relation ] [ create-relation* ] ensure2 ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 257133c67f..fad2ea6332 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -24,16 +24,15 @@ 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 + "test content" create-context* context set + [ 4 ] [ context get ] unit-test + [ 5 ] [ context get "is test content" create-relation* ] unit-test + [ 5 ] [ context get "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 get node-content ] unit-test ! 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 @@ -52,21 +51,21 @@ 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 ] 2apply 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 + "family tree" create-context* context set + "has parent" relation-id has-parent-relation set + "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 ] 2apply 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-db delete-db From 09c61d7d0a94d33c60ecd9babce043b0c70547d0 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sun, 16 Mar 2008 13:25:27 +1100 Subject: [PATCH 03/24] new-graphs: starting a library that has directed and undirected graphs --- extra/new-graphs/new-graphs.factor | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 extra/new-graphs/new-graphs.factor diff --git a/extra/new-graphs/new-graphs.factor b/extra/new-graphs/new-graphs.factor new file mode 100644 index 0000000000..b82ed8a22d --- /dev/null +++ b/extra/new-graphs/new-graphs.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel new-slots sequences vectors ; +IN: new-graphs + +TUPLE: graph edges ; +TUPLE: digraph ; +TUPLE: undigraph ; + +: ( -- graph ) + H{ } clone graph construct-boa H{ } clone over set-delegate ; + +: ( -- graph ) + digraph construct-empty tuck set-delegate ; + +: ( -- graph ) + undigraph construct-empty tuck set-delegate ; + +GENERIC: add-vertex ( key value graph -- ) +M: graph add-vertex ( key value digraph -- ) set-at ; + From c90c0025c7544e54bb696e686a7271f55d55f2f7 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 19 Mar 2008 21:22:15 +1100 Subject: [PATCH 04/24] semantic-db: move everything into one vocab --- extra/semantic-db/context/context.factor | 10 --- extra/semantic-db/hierarchy/hierarchy.factor | 44 --------- .../semantic-db/membership/membership.factor | 6 -- extra/semantic-db/relations/relations.factor | 26 ------ extra/semantic-db/semantic-db-tests.factor | 66 +++++++------- extra/semantic-db/semantic-db.factor | 90 +++++++++++++++---- 6 files changed, 107 insertions(+), 135 deletions(-) delete mode 100644 extra/semantic-db/context/context.factor delete mode 100644 extra/semantic-db/hierarchy/hierarchy.factor delete mode 100644 extra/semantic-db/membership/membership.factor delete mode 100644 extra/semantic-db/relations/relations.factor diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor deleted file mode 100644 index 9d2e175b5e..0000000000 --- a/extra/semantic-db/context/context.factor +++ /dev/null @@ -1,10 +0,0 @@ -! 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 ; - -SYMBOL: context - diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor deleted file mode 100644 index f180ddb5df..0000000000 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ /dev/null @@ -1,44 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples hashtables kernel namespaces new-slots -semantic-db semantic-db.relations sequences sequences.deep ; -IN: semantic-db.hierarchy - -TUPLE: tree id children ; -C: tree - -SYMBOL: has-parent-relation - -: parent-child* ( parent child -- arc-id ) - has-parent-relation get spin create-arc* ; - -: parent-child ( parent child -- ) - parent-child* drop ; - -: un-parent-child ( parent child -- ) - has-parent-relation get spin select-tuples [ id>> delete-arc ] each ; - -: child-arcs ( node-id -- child-arcs ) - has-parent-relation get f rot select-tuples ; - -: children ( node-id -- children ) - child-arcs [ subject>> ] map ; - -: parent-arcs ( node-id -- parent-arcs ) - has-parent-relation get swap f select-tuples ; - -: parents ( node-id -- parents ) - parent-arcs [ object>> ] map ; - -: get-node-hierarchy ( node-id -- tree ) - dup children [ get-node-hierarchy ] map ; - -: (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 ; diff --git a/extra/semantic-db/membership/membership.factor b/extra/semantic-db/membership/membership.factor deleted file mode 100644 index c386922979..0000000000 --- a/extra/semantic-db/membership/membership.factor +++ /dev/null @@ -1,6 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel new-slots semantic-db semantic-db.relations ; -IN: semantic-db.membership - - diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor deleted file mode 100644 index 58003c9e9d..0000000000 --- a/extra/semantic-db/relations/relations.factor +++ /dev/null @@ -1,26 +0,0 @@ -! 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 get swap [ get-relation ] [ create-relation* ] ensure2 ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index fad2ea6332..47363b8f5d 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,10 +1,12 @@ -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 -tools.walker ; +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 +SYMBOL: has-parent-relation + : db-path "semantic-db-test.db" temp-file ; : test-db db-path sqlite-db ; : delete-db [ db-path delete-file ] ignore-errors ; @@ -13,25 +15,25 @@ 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 + [ 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* context set + "test content" create-context context set [ 4 ] [ context get ] unit-test - [ 5 ] [ context get "is test content" create-relation* ] unit-test - [ 5 ] [ context get "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 + [ 5 ] [ "is test content" context get create-relation ] unit-test + [ 5 ] [ "is test content" context get get-relation ] unit-test + [ 5 ] [ "is test content" context get relation-id ] unit-test + [ 7 ] [ "has parent" context get relation-id ] unit-test + [ 7 ] [ "has parent" context get relation-id ] unit-test + [ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test [ "test content" ] [ context get node-content ] unit-test ! type-type 1array [ "type" ensure-type ] unit-test ! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test @@ -51,21 +53,21 @@ delete-db ! test hierarchy test-db [ init-semantic-db - "family tree" create-context* context set - "has parent" relation-id has-parent-relation set - "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 ] 2apply 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 + "family tree" create-context context set + "has parent" context get relation-id has-parent-relation set + "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 has-parent-relation get parent-child integer? ] unit-test + { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply has-parent-relation get parent-child drop ] each + [ { "bob" "fran" } ] [ "eve" get has-parent-relation get children [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "bob" get has-parent-relation get parents [ node-content ] map ] unit-test + [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get get-root-nodes [ node-content ] map natural-sort >array ] unit-test + [ { } ] [ "fran" get "charlie" get tuck has-parent-relation get un-parent-child has-parent-relation get parents [ node-content ] map ] unit-test ] with-db delete-db diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index e8075c016d..340514fd11 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,6 +1,6 @@ ! 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 new-slots sequences ; +USING: accessors arrays continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots sequences sequences.deep sequences.lib ; IN: semantic-db TUPLE: node id content ; @@ -22,19 +22,16 @@ node "node" : delete-node ( node-id -- ) delete-tuple ; -: create-node* ( str -- node-id ) +: create-node ( str -- node-id ) dup insert-tuple id>> ; -: create-node ( str -- ) - create-node* drop ; - : node-content ( id -- str ) f swap >>id select-tuple content>> ; -TUPLE: arc id relation subject object ; +TUPLE: arc id subject object relation ; -: ( relation subject object -- arc ) - arc construct-empty swap >>object swap >>subject swap >>relation ; +: ( subject object relation -- arc ) + arc construct-empty swap >>relation swap >>object swap >>subject ; : ( id -- arc ) arc construct-empty swap >>id ; @@ -45,12 +42,9 @@ TUPLE: arc id relation subject object ; : delete-arc ( arc-id -- ) dup delete-node delete-tuple ; -: create-arc* ( relation subject object -- arc-id ) +: create-arc ( subject object relation -- arc-id ) dup insert-arc id>> ; -: create-arc ( relation subject object -- ) - create-arc* drop ; - arc "arc" { { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? @@ -59,18 +53,17 @@ arc "arc" { "object" "object" INTEGER +not-null+ } } define-persistent -: create-arc-table ( -- ) - arc create-table ; +: 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 ; : 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 drop ; : init-semantic-db ( -- ) create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; @@ -87,3 +80,66 @@ arc "arc" #! quot2 ( x y -- z ) creates a new z if quot1 returns f >r >r 2dup r> call [ 2nip ] r> if* ; +: create-context ( context-name -- context-id ) create-node ; + +! relations: +! - have a context in context 'semantic-db' + +: create-relation ( relation-name context-id -- relation-id ) + [ create-node dup ] dip has-context-relation create-arc drop ; + +: get-relation ( relation-name context-id -- relation-id/f ) + [ + ":context" INTEGER param , + ":name" TEXT 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 context-id -- relation-id ) + [ get-relation ] [ create-relation ] ensure2 ; + +! hierarchy +TUPLE: tree id children ; +C: tree + +: parent-child ( parent child has-parent-relation -- arc-id ) swapd create-arc ; + +: un-parent-child ( parent child has-parent-relation -- ) + swapd select-tuples [ id>> delete-arc ] each ; + +: child-arcs ( parent-id has-parent-relation -- child-arcs ) + f -rot select-tuples ; + +: children ( node-id has-parent-relation -- children ) + child-arcs [ subject>> ] map ; + +: parent-arcs ( node-id has-parent-relation -- parent-arcs ) + f swap select-tuples ; + +: parents ( node-id has-parent-relation -- parents ) + parent-arcs [ object>> ] map ; + +: get-node-hierarchy ( node-id has-parent-relation -- tree ) + 2dup children >r [ get-node-hierarchy ] curry r> swap map ; + +: (get-root-nodes) ( node-id has-parent-relation -- root-nodes/node-id ) + 2dup parents dup empty? [ + 2drop + ] [ + >r nip [ (get-root-nodes) ] curry r> swap map + ] if ; + +: get-root-nodes ( node-id has-parent-relation -- root-nodes ) + (get-root-nodes) flatten prune ; + +! sets + +: in-set* ( set member in-set-relation -- arc-id ) swapd create-arc ; + +: in-set? ( set member in-set-relation -- ? ) + swapd select-tuples length 0 > ; + +: set-members ( set in-set-relation -- members ) + f -rot select-tuples [ id>> ] map ; From 3df71e5447c05fb6e815124ddd40af66de4ff0cf Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 21 Mar 2008 02:01:58 +1100 Subject: [PATCH 05/24] semantic-db: add RELATION: --- extra/semantic-db/semantic-db-tests.factor | 31 +++---- extra/semantic-db/semantic-db.factor | 97 ++++++++++++++++------ 2 files changed, 81 insertions(+), 47 deletions(-) diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 47363b8f5d..0dccab330b 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -14,15 +14,13 @@ SYMBOL: has-parent-relation delete-db test-db [ - create-node-table create-arc-table + node create-table arc create-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 +] with-db delete-db test-db [ init-semantic-db @@ -35,20 +33,7 @@ test-db [ [ 7 ] [ "has parent" context get relation-id ] unit-test [ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test [ "test content" ] [ context get node-content ] unit-test - ! 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 - -delete-db +] with-db delete-db ! test hierarchy test-db [ @@ -68,6 +53,12 @@ test-db [ [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get get-root-nodes [ node-content ] map natural-sort >array ] unit-test [ { } ] [ "fran" get "charlie" get tuck has-parent-relation get un-parent-child has-parent-relation get parents [ node-content ] map ] unit-test -] with-db +] with-db delete-db + +RELATION: test-relation + +test-db [ + init-semantic-db + [ 5 ] [ test-relation ] unit-test +] with-db delete-db -delete-db diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 340514fd11..f73b76327b 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,6 +1,6 @@ ! 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 hashtables kernel math math.parser namespaces new-slots sequences sequences.deep sequences.lib ; +USING: accessors arrays combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib words ; IN: semantic-db TUPLE: node id content ; @@ -16,9 +16,6 @@ node "node" { "content" "content" TEXT } } define-persistent -: create-node-table ( -- ) - node create-table ; - : delete-node ( node-id -- ) delete-tuple ; @@ -45,6 +42,30 @@ TUPLE: arc id subject object relation ; : create-arc ( subject object relation -- arc-id ) dup insert-arc id>> ; +: has-arc? ( subject object relation -- ? ) + select-tuples length 0 > ; + +: select-arcs ( subject object relation -- arcs ) + select-tuples ; + +: select-arc-ids ( subject object relation -- arc-ids ) + select-arcs [ id>> ] map ; + +: select-arc-subjects ( subject object relation -- subject-ids ) + select-arcs [ subject>> ] map ; + +: select-arc-objects ( subject object relation -- object-ids ) + select-arcs [ object>> ] map ; + +: delete-arcs ( subject object relation -- ) + select-arcs [ id>> delete-arc ] each ; + +: subject-relation ( subject relation -- subject object relation ) + f swap ; + +: object-relation ( object relation -- subject object relation ) + f -rot ; + arc "arc" { { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? @@ -53,20 +74,20 @@ arc "arc" { "object" "object" INTEGER +not-null+ } } define-persistent -: create-arc-table ( -- ) arc create-table ; - : create-bootstrap-nodes ( -- ) "semantic-db" create-node drop - "has context" create-node drop ; + "has-context" create-node drop ; -: semantic-db-context 1 ; +: semantic-db-context 1 ; : has-context-relation 2 ; : create-bootstrap-arcs ( -- ) has-context-relation semantic-db-context has-context-relation create-arc drop ; : 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 ; @@ -75,13 +96,31 @@ arc "arc" f f [ do-bound-query ] with-disposal [ first string>number ] map ; +: ensure1 ( x quot1 quot2 -- y ) + #! quot1 ( x -- y/f ) tries to find an existing y + #! quot2 ( x -- y ) creates a new y if quot1 returns f + >r dupd call [ nip ] r> if* ; + : ensure2 ( x y quot1 quot2 -- z ) - #! quot1 ( x y -- z/f ) finds an existing z + #! quot1 ( x y -- z/f ) tries to find an existing z #! quot2 ( x y -- z ) creates a new z if quot1 returns f >r >r 2dup r> call [ 2nip ] r> if* ; +! contexts: +! - a node n is a context iff there exists a relation r such that r has context n : create-context ( context-name -- context-id ) create-node ; +: get-context ( context-name -- context-id/f ) + [ + ":name" TEXT param , + has-context-relation ":has_context" INTEGER param , + ] { } make + "select distinct n.id from node n, arc a where n.content = :name and a.relation = :has_context and a.object = n.id" + single-int-results ?first ; + +: context-id ( context-name -- context-id ) + [ get-context ] [ create-context ] ensure1 ; + ! relations: ! - have a context in context 'semantic-db' @@ -100,26 +139,28 @@ arc "arc" : relation-id ( relation-name context-id -- relation-id ) [ get-relation ] [ create-relation ] ensure2 ; +! RELATION: is-fooey +! - define a word is-fooey in the current vocab (foo), that when called: +! - finds or creates a node called "is-fooey" with context "foo", and returns its id +: RELATION: + CREATE-WORD dup [ word-name ] [ word-vocabulary ] bi + [ context-id relation-id ] 2curry define ; parsing + ! hierarchy TUPLE: tree id children ; C: tree -: parent-child ( parent child has-parent-relation -- arc-id ) swapd create-arc ; +: parent-child ( parent child has-parent-relation -- arc-id ) + swapd create-arc ; : un-parent-child ( parent child has-parent-relation -- ) - swapd select-tuples [ id>> delete-arc ] each ; - -: child-arcs ( parent-id has-parent-relation -- child-arcs ) - f -rot select-tuples ; + swapd delete-arcs ; : children ( node-id has-parent-relation -- children ) - child-arcs [ subject>> ] map ; - -: parent-arcs ( node-id has-parent-relation -- parent-arcs ) - f swap select-tuples ; + object-relation select-arc-subjects ; : parents ( node-id has-parent-relation -- parents ) - parent-arcs [ object>> ] map ; + subject-relation select-arc-objects ; : get-node-hierarchy ( node-id has-parent-relation -- tree ) 2dup children >r [ get-node-hierarchy ] curry r> swap map ; @@ -135,11 +176,13 @@ C: tree (get-root-nodes) flatten prune ; ! sets - -: in-set* ( set member in-set-relation -- arc-id ) swapd create-arc ; - -: in-set? ( set member in-set-relation -- ? ) - swapd select-tuples length 0 > ; - +: in-set ( member set in-set-relation -- arc-id ) create-arc ; +: in-set? ( member set in-set-relation -- ? ) has-arc? ; : set-members ( set in-set-relation -- members ) - f -rot select-tuples [ id>> ] map ; + object-relation select-arc-subjects ; + +! attributes +: has-attribute ( node value has-attribute-relation -- arc-id ) create-arc ; +: has-attribute? ( node value has-attribute-relation -- ? ) has-arc? ; +: nodes-with-attribute ( value has-attribute-relation -- node-ids ) + object-relation select-arc-subjects ; From 43aba96e8c858617638edf8e5ff3796f24f2b4f8 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 25 Mar 2008 17:38:14 +1100 Subject: [PATCH 06/24] semantic-db: new RELATION: syntax --- extra/semantic-db/semantic-db-tests.factor | 81 +++++++++--------- extra/semantic-db/semantic-db.factor | 96 ++++++++++++++-------- 2 files changed, 102 insertions(+), 75 deletions(-) diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 0dccab330b..7fa0ff2176 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -5,7 +5,6 @@ sequences sorting tools.test tools.walker ; IN: semantic-db.tests SYMBOL: context -SYMBOL: has-parent-relation : db-path "semantic-db-test.db" temp-file ; : test-db db-path sqlite-db ; @@ -22,43 +21,43 @@ test-db [ [ 5 ] [ 1 2 3 create-arc ] unit-test ] with-db delete-db -test-db [ - init-semantic-db - "test content" create-context context set - [ 4 ] [ context get ] unit-test - [ 5 ] [ "is test content" context get create-relation ] unit-test - [ 5 ] [ "is test content" context get get-relation ] unit-test - [ 5 ] [ "is test content" context get relation-id ] unit-test - [ 7 ] [ "has parent" context get relation-id ] unit-test - [ 7 ] [ "has parent" context get relation-id ] unit-test - [ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test - [ "test content" ] [ context get node-content ] unit-test -] with-db delete-db - -! test hierarchy -test-db [ - init-semantic-db - "family tree" create-context context set - "has parent" context get relation-id has-parent-relation set - "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 has-parent-relation get parent-child integer? ] unit-test - { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply has-parent-relation get parent-child drop ] each - [ { "bob" "fran" } ] [ "eve" get has-parent-relation get children [ node-content ] map ] unit-test - [ { "adam" "eve" } ] [ "bob" get has-parent-relation get parents [ node-content ] map ] unit-test - [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test - [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get get-root-nodes [ node-content ] map natural-sort >array ] unit-test - [ { } ] [ "fran" get "charlie" get tuck has-parent-relation get un-parent-child has-parent-relation get parents [ node-content ] map ] unit-test -] with-db delete-db - -RELATION: test-relation - -test-db [ - init-semantic-db - [ 5 ] [ test-relation ] unit-test -] with-db delete-db - + test-db [ + init-semantic-db + "test content" create-context context set + [ 4 ] [ context get ] unit-test + [ 5 ] [ "is test content" context get create-relation ] unit-test + [ 5 ] [ "is test content" context get get-relation ] unit-test + [ 5 ] [ "is test content" context get relation-id ] unit-test + [ 7 ] [ "has parent" context get relation-id ] unit-test + [ 7 ] [ "has parent" context get relation-id ] unit-test + [ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test + [ "test content" ] [ context get node-content ] unit-test + ] with-db delete-db + + ! "test1" f f f f f define-relation + ! "test2" t t t t t define-relation + RELATION: test + test-db [ + init-semantic-db + [ 5 ] [ test-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 + [ t ] [ "bob" get "adam" get has-parent integer? ] unit-test + { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent drop ] 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-hierarchy dup tree-id node-content swap tree-children [ tree-id 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 + ] with-db delete-db + diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index f73b76327b..d4e2c1ed1a 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib words ; +USING: accessors arrays combinators combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib strings words ; IN: semantic-db TUPLE: node id content ; @@ -54,18 +54,18 @@ TUPLE: arc id subject object relation ; : select-arc-subjects ( subject object relation -- subject-ids ) select-arcs [ subject>> ] map ; +: select-subjects ( object relation -- subject-ids ) + f -rot select-arc-subjects ; + : select-arc-objects ( subject object relation -- object-ids ) select-arcs [ object>> ] map ; +: select-objects ( subject relation -- object-ids ) + f swap select-arc-objects ; + : delete-arcs ( subject object relation -- ) select-arcs [ id>> delete-arc ] each ; -: subject-relation ( subject relation -- subject object relation ) - f swap ; - -: object-relation ( object relation -- subject object relation ) - f -rot ; - arc "arc" { { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? @@ -139,28 +139,67 @@ arc "arc" : relation-id ( relation-name context-id -- relation-id ) [ get-relation ] [ create-relation ] ensure2 ; -! RELATION: is-fooey -! - define a word is-fooey in the current vocab (foo), that when called: -! - finds or creates a node called "is-fooey" with context "foo", and returns its id +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 + [ context-id relation-id ] 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: - CREATE-WORD dup [ word-name ] [ word-vocabulary ] bi - [ context-id relation-id ] 2curry define ; parsing + scan t t t t t define-relation ; parsing ! hierarchy TUPLE: tree id children ; C: tree -: parent-child ( parent child has-parent-relation -- arc-id ) - swapd create-arc ; - -: un-parent-child ( parent child has-parent-relation -- ) - swapd delete-arcs ; - -: children ( node-id has-parent-relation -- children ) - object-relation select-arc-subjects ; - -: parents ( node-id has-parent-relation -- parents ) - subject-relation select-arc-objects ; +: children ( node-id has-parent-relation -- children ) select-subjects ; +: parents ( node-id has-parent-relation -- parents ) select-objects ; : get-node-hierarchy ( node-id has-parent-relation -- tree ) 2dup children >r [ get-node-hierarchy ] curry r> swap map ; @@ -175,14 +214,3 @@ C: tree : get-root-nodes ( node-id has-parent-relation -- root-nodes ) (get-root-nodes) flatten prune ; -! sets -: in-set ( member set in-set-relation -- arc-id ) create-arc ; -: in-set? ( member set in-set-relation -- ? ) has-arc? ; -: set-members ( set in-set-relation -- members ) - object-relation select-arc-subjects ; - -! attributes -: has-attribute ( node value has-attribute-relation -- arc-id ) create-arc ; -: has-attribute? ( node value has-attribute-relation -- ? ) has-arc? ; -: nodes-with-attribute ( value has-attribute-relation -- node-ids ) - object-relation select-arc-subjects ; From 18a09b54b1619e35ac3f8b9cfb309fca38fee245 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 25 Mar 2008 23:00:06 +1100 Subject: [PATCH 07/24] semantic-db: trivial change --- extra/semantic-db/semantic-db.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index d4e2c1ed1a..ee276260f3 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -23,7 +23,7 @@ node "node" dup insert-tuple id>> ; : node-content ( id -- str ) - f swap >>id select-tuple content>> ; + select-tuple content>> ; TUPLE: arc id subject object relation ; From 4c449296b207fba5ba4de2125e0e6beb5ef93292 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 11:18:32 -0500 Subject: [PATCH 08/24] Fix NetBSD FFI --- core/cpu/x86/architecture/architecture.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 49b05ea48f..f993639c05 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -156,7 +156,7 @@ M: x86-backend %unbox-small-struct ( size -- ) M: x86-backend struct-small-enough? ( size -- ? ) { 1 2 4 8 } member? - os { "linux" "solaris" } member? not and ; + os { "linux" "netbsd" "solaris" } member? not and ; M: x86-backend %return ( -- ) 0 %unwind ; From aad587d6647607042bbbed72e59cbbb67d801c46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 11:48:51 -0500 Subject: [PATCH 09/24] Fix deploy test --- extra/tools/deploy/deploy-tests.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 8db34320de..5030763a3d 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,10 +1,11 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math sequences io.launcher arrays -namespaces ; +namespaces continuations ; : shake-and-bake ( vocab -- ) - "." resource-path [ + [ "test.image" temp-file delete-file ] ignore-errors + "resource:" [ >r vm "test.image" temp-file r> dup deploy-config make-deploy-image From 5dd354333ff18503d54b54ab81d96acd8b18e08a Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 1 Apr 2008 12:07:02 +1100 Subject: [PATCH 10/24] semantic-db: pass around node objects instead of ids --- extra/semantic-db/semantic-db-tests.factor | 45 ++-- extra/semantic-db/semantic-db.factor | 227 +++++++++++++-------- 2 files changed, 169 insertions(+), 103 deletions(-) diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 7fa0ff2176..ac620de4d9 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,7 +1,6 @@ USING: accessors arrays continuations db db.sqlite db.tuples io.files -kernel math namespaces semantic-db - -sequences sorting tools.test tools.walker ; +kernel math namespaces semantic-db sequences sorting tools.test +tools.walker ; IN: semantic-db.tests SYMBOL: context @@ -14,32 +13,34 @@ delete-db test-db [ node create-table arc create-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 + [ 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 2 f 3 f create-arc ] unit-test ] with-db delete-db test-db [ init-semantic-db "test content" create-context context set - [ 4 ] [ context get ] unit-test - [ 5 ] [ "is test content" context get create-relation ] unit-test - [ 5 ] [ "is test content" context get get-relation ] unit-test - [ 5 ] [ "is test content" context get relation-id ] unit-test - [ 7 ] [ "has parent" context get relation-id ] unit-test - [ 7 ] [ "has parent" context get relation-id ] unit-test - [ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test + [ 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" f f f f f define-relation + ! "test1" "test1-relation-id-word" f f f f define-relation ! "test2" t t t t t define-relation - RELATION: test + RELATION: test3 test-db [ init-semantic-db - [ 5 ] [ test-relation ] unit-test + ! [ 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 @@ -52,12 +53,14 @@ test-db [ "fran" create-node "fran" set "charlie" create-node "charlie" set "gertrude" create-node "gertrude" set - [ t ] [ "bob" get "adam" get has-parent integer? ] unit-test - { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent drop ] each + [ ] [ "bob" get "adam" get has-parent ] unit-test + { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply 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-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test + [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get-node-hierarchy 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 diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index ee276260f3..2500441b11 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib strings words ; +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 ; -: ( content -- node ) - node construct-empty swap >>content ; - -: ( id -- node ) - node construct-empty swap >>id ; +C: node node "node" { @@ -16,15 +15,14 @@ node "node" { "content" "content" TEXT } } define-persistent -: delete-node ( node-id -- ) - delete-tuple ; +: delete-node ( node -- ) delete-tuple ; +: create-node ( content -- node ) f swap dup insert-tuple ; +: load-node ( id -- node ) f select-tuple ; -: create-node ( str -- node-id ) - dup insert-tuple id>> ; - -: node-content ( id -- str ) - select-tuple content>> ; +: node-content ( node -- content ) + dup content>> [ nip ] [ select-tuple content>> ] if* ; +! TODO: get rid of arc id and write our own sql TUPLE: arc id subject object relation ; : ( subject object relation -- arc ) @@ -33,42 +31,50 @@ TUPLE: arc id subject object relation ; : ( id -- arc ) arc construct-empty swap >>id ; -: insert-arc ( arc -- ) - f dup insert-tuple id>> >>id insert-tuple ; +: delete-arc ( arc -- ) delete-tuple ; -: delete-arc ( arc-id -- ) - dup delete-node delete-tuple ; +: create-arc ( subject object relation -- ) + [ id>> ] 3apply insert-tuple ; -: create-arc ( subject object relation -- arc-id ) - dup insert-arc id>> ; - -: has-arc? ( subject object relation -- ? ) - select-tuples length 0 > ; +: nodes>arc ( subject object relation -- arc ) + [ [ id>> ] [ f ] if* ] 3apply ; : select-arcs ( subject object relation -- arcs ) - select-tuples ; + nodes>arc select-tuples ; -: select-arc-ids ( subject object relation -- arc-ids ) - select-arcs [ id>> ] map ; +: has-arc? ( subject object relation -- ? ) + select-arcs length 0 > ; -: select-arc-subjects ( subject object relation -- subject-ids ) - select-arcs [ subject>> ] map ; +: select-arc-subjects ( subject object relation -- subjects ) + select-arcs [ subject>> f ] map ; -: select-subjects ( object relation -- subject-ids ) +: select-arc-subject ( subject object relation -- subject ) + select-arcs ?first [ subject>> f ] [ f ] if* ; + +: select-subjects ( object relation -- subjects ) f -rot select-arc-subjects ; -: select-arc-objects ( subject object relation -- object-ids ) - select-arcs [ object>> ] map ; +: select-subject ( object relation -- subject ) + f -rot select-arc-subject ; -: select-objects ( subject relation -- object-ids ) +: select-arc-objects ( subject object relation -- objects ) + select-arcs [ object>> f ] map ; + +: select-arc-object ( subject object relation -- object ) + select-arcs ?first [ object>> f ] [ 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 [ id>> delete-arc ] each ; + 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+ } @@ -78,66 +84,99 @@ arc "arc" "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 semantic-db-context has-context-relation create-arc drop ; + has-context-relation semantic-db-context has-context-relation create-arc ; : init-semantic-db ( -- ) - node create-table - arc create-table + node create-table arc create-table create-bootstrap-nodes create-bootstrap-arcs ; -: param ( value key type -- param ) - swapd 3array ; +: param ( value key type -- param ) swapd 3array ; -: single-int-results ( bindings sql -- array ) - f f [ do-bound-query ] with-disposal - [ first string>number ] map ; +! db utilities +: results ( bindings sql -- array ) + f f [ do-bound-query ] with-disposal ; -: ensure1 ( x quot1 quot2 -- y ) - #! quot1 ( x -- y/f ) tries to find an existing y - #! quot2 ( x -- y ) creates a new y if quot1 returns f - >r dupd call [ nip ] r> if* ; +: node-result ( result -- node ) + dup first string>number swap second ; -: ensure2 ( x y quot1 quot2 -- z ) - #! quot1 ( x y -- z/f ) tries to find an existing z - #! quot2 ( x y -- z ) creates a new z if quot1 returns f - >r >r 2dup r> call [ 2nip ] r> if* ; +: ?1node-result ( results -- node ) + ?first [ node-result ] [ f ] if* ; + +: node-results ( results -- nodes ) + [ node-result ] map ; + +: subjects-with-cor ( content object relation -- sql-results ) + [ id>> ] 2apply + [ + ":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>> ] 2apply + [ + ":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-id ) create-node ; +: create-context ( context-name -- context ) create-node ; -: get-context ( context-name -- context-id/f ) - [ - ":name" TEXT param , - has-context-relation ":has_context" INTEGER param , - ] { } make - "select distinct n.id from node n, arc a where n.content = :name and a.relation = :has_context and a.object = n.id" - single-int-results ?first ; +: get-context ( context-name -- context/f ) + has-context-relation subjects-with-relation ?1node-result ; -: context-id ( context-name -- context-id ) - [ get-context ] [ create-context ] ensure1 ; +: 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-id -- relation-id ) - [ create-node dup ] dip has-context-relation create-arc drop ; +: create-relation ( relation-name context -- relation ) + [ create-node dup ] dip has-context-relation create-arc ; -: get-relation ( relation-name context-id -- relation-id/f ) - [ - ":context" INTEGER param , - ":name" TEXT 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 ; +: get-relation ( relation-name context -- relation/f ) + has-context-relation subjects-with-cor ?1node-result ; -: relation-id ( relation-name context-id -- relation-id ) - [ get-relation ] [ create-relation ] ensure2 ; +: 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 @@ -181,7 +220,7 @@ C: relation-definition : define-id-word ( relation-definition id-word -- ) [ relate>> ] dip tuck word-vocabulary - [ context-id relation-id ] 2curry define ; + [ ensure-context ensure-relation ] 2curry define ; : create-id-word ( relation-definition -- id-word ) dup id-word>> "id-word" choose-word-name create-in ; @@ -195,22 +234,46 @@ PRIVATE> scan t t t t t define-relation ; parsing ! hierarchy -TUPLE: tree id children ; -C: tree +TUPLE: node-tree node children ; +C: node-tree -: children ( node-id has-parent-relation -- children ) select-subjects ; -: parents ( node-id has-parent-relation -- parents ) select-objects ; +: children ( node has-parent-relation -- children ) select-subjects ; +: parents ( node has-parent-relation -- parents ) select-objects ; -: get-node-hierarchy ( node-id has-parent-relation -- tree ) - 2dup children >r [ get-node-hierarchy ] curry r> swap map ; +: get-node-tree ( node child-selector -- node-tree ) + 2dup call >r [ get-node-tree ] curry r> swap map ; -: (get-root-nodes) ( node-id has-parent-relation -- root-nodes/node-id ) +! : 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 ; -: get-root-nodes ( node-id has-parent-relation -- root-nodes ) +: get-root-nodes ( node has-parent-relation -- root-nodes ) (get-root-nodes) flatten prune ; From e8abcf8d8583c917ba85790d21f775778f7d716e Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 1 Apr 2008 13:41:03 +1100 Subject: [PATCH 11/24] semantic-db: change 2apply to bi@ --- extra/semantic-db/semantic-db-tests.factor | 4 ++-- extra/semantic-db/semantic-db.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index ac620de4d9..8fec6d5cbb 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -54,10 +54,10 @@ test-db [ "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 ] 2apply has-parent ] each + { { "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-hierarchy dup node>> node-content swap children>> [ node>> 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 diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 2500441b11..b33d795c9c 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -110,7 +110,7 @@ arc "arc" [ node-result ] map ; : subjects-with-cor ( content object relation -- sql-results ) - [ id>> ] 2apply + [ id>> ] bi@ [ ":relation" INTEGER param , ":object" INTEGER param , @@ -119,7 +119,7 @@ arc "arc" "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>> ] 2apply + [ id>> ] bi@ [ ":relation" INTEGER param , ":subject" INTEGER param , From 21e30d86815a813aed7c099867e619e368910b64 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 9 Apr 2008 09:22:12 +1000 Subject: [PATCH 12/24] semantic-db: add node= --- extra/semantic-db/semantic-db.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index b33d795c9c..2ac667a94c 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -22,6 +22,8 @@ node "node" : node-content ( node -- content ) dup content>> [ nip ] [ select-tuple content>> ] if* ; +: node= ( node node -- ? ) [ id>> ] bi@ = ; + ! TODO: get rid of arc id and write our own sql TUPLE: arc id subject object relation ; From 7a748b23c8021db06fa2f563b612be70be268333 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 9 Apr 2008 09:23:33 +1000 Subject: [PATCH 13/24] initial work on tangle --- extra/tangle/html/html-tests.factor | 7 ++++ extra/tangle/html/html.factor | 33 +++++++++++++++++++ extra/tangle/menu/menu.factor | 22 +++++++++++++ extra/tangle/page/page.factor | 23 +++++++++++++ extra/tangle/path/path.factor | 51 +++++++++++++++++++++++++++++ extra/tangle/tangle-tests.factor | 26 +++++++++++++++ extra/tangle/tangle.factor | 49 +++++++++++++++++++++++++++ 7 files changed, 211 insertions(+) create mode 100644 extra/tangle/html/html-tests.factor create mode 100644 extra/tangle/html/html.factor create mode 100644 extra/tangle/menu/menu.factor create mode 100644 extra/tangle/page/page.factor create mode 100644 extra/tangle/path/path.factor create mode 100644 extra/tangle/tangle-tests.factor create mode 100644 extra/tangle/tangle.factor diff --git a/extra/tangle/html/html-tests.factor b/extra/tangle/html/html-tests.factor new file mode 100644 index 0000000000..8e7d8c24e1 --- /dev/null +++ b/extra/tangle/html/html-tests.factor @@ -0,0 +1,7 @@ +USING: html kernel semantic-db tangle.html tools.test ; +IN: tangle.html.tests + +[ "test" ] [ "test" >html ] unit-test +[ "
  • An Item
" ] [ { "An Item" } >html ] unit-test +[ "
  • One
  • Two
  • Three, ah ah ah
" ] [ { "One" "Two" "Three, ah ah ah" } >html ] unit-test +[ "some link" ] [ "foo/bar" "some link" >html ] unit-test diff --git a/extra/tangle/html/html.factor b/extra/tangle/html/html.factor new file mode 100644 index 0000000000..9c55b66528 --- /dev/null +++ b/extra/tangle/html/html.factor @@ -0,0 +1,33 @@ +! 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 ; +: ( items -- element ) + H{ } clone swap ulist construct-boa ; + +TUPLE: link < element href text ; +: ( href text -- element ) + H{ } clone -rot link construct-boa ; + +GENERIC: >html ( element -- str ) + +M: string >html ( str -- str ) ; + +M: link >html ( link -- str ) + [ > =href a> text>> write ] with-string-writer ; + +M: node >html ( node -- str ) + dup node>path [ + swap node-content >html + ] [ + node-content + ] if* ; + +M: ulist >html ( ulist -- str ) + [ +
    items>> [
  • >html write
    • ] each
+ ] with-string-writer ; diff --git a/extra/tangle/menu/menu.factor b/extra/tangle/menu/menu.factor new file mode 100644 index 0000000000..9740acee1c --- /dev/null +++ b/extra/tangle/menu/menu.factor @@ -0,0 +1,22 @@ +! 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>> ; +: menu>html ( menu -- str ) menu>ulist >html ; diff --git a/extra/tangle/page/page.factor b/extra/tangle/page/page.factor new file mode 100644 index 0000000000..db3d58d5f3 --- /dev/null +++ b/extra/tangle/page/page.factor @@ -0,0 +1,23 @@ +! 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 + +: 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 ; diff --git a/extra/tangle/path/path.factor b/extra/tangle/path/path.factor new file mode 100644 index 0000000000..e7cf3de967 --- /dev/null +++ b/extra/tangle/path/path.factor @@ -0,0 +1,51 @@ +! 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 ] [ "/" join ] if ; + +: node>path ( node -- path ) + ensure-root swap node>path* ; diff --git a/extra/tangle/tangle-tests.factor b/extra/tangle/tangle-tests.factor new file mode 100644 index 0000000000..7b78e07473 --- /dev/null +++ b/extra/tangle/tangle-tests.factor @@ -0,0 +1,26 @@ +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 diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor new file mode 100644 index 0000000000..cbd3b94058 --- /dev/null +++ b/extra/tangle/tangle.factor @@ -0,0 +1,49 @@ +! 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 + +M: echo-template render* drop ; +! METHOD: render* { string echo-template } drop ; +M: object render render* write ; + +TUPLE: tangle db templater ; +C: tangle + +TUPLE: sqlite-tangle ; +TUPLE: postgres-tangle ; + +: make-tangle ( db templater type -- tangle ) + construct-empty [ ] dip tuck set-delegate ; + +: ( db templater -- tangle ) sqlite-tangle make-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 + +M: node-responder call-responder ( path responder -- response ) + "text/plain" nip request-params + [ "node-id" swap at* [ >>body ] [ drop ] if ] when* nip ; + +: test-tangle ( -- ) + f f main-responder set ; + From 14426af0c35c0e9650524b03e0ca0fb6cdc3cdca Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 9 Apr 2008 17:38:04 +1000 Subject: [PATCH 14/24] adding bank account simulator --- extra/bank/bank-tests.factor | 34 ++++++++++++++++ extra/bank/bank.factor | 76 ++++++++++++++++++++++++++---------- 2 files changed, 90 insertions(+), 20 deletions(-) create mode 100644 extra/bank/bank-tests.factor diff --git a/extra/bank/bank-tests.factor b/extra/bank/bank-tests.factor new file mode 100644 index 0000000000..2aa31f1e85 --- /dev/null +++ b/extra/bank/bank-tests.factor @@ -0,0 +1,34 @@ +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 6101.94 open-account my-account set + [ 6137 ] [ my-account get 2007 12 2 process-to-date balance>> round >integer ] unit-test + [ 6137 ] [ my-account get 2007 12 2 process-to-date balance>> round >integer ] unit-test +] with-scope + +[ + "Petty Cash" 0.07 1 2006 12 1 10962.18 open-account my-account set + [ 11027 ] [ my-account get 2007 1 2 process-to-date balance>> round >integer ] unit-test +] with-scope + +[ + "Saving to buy a pony" 0.0725 1 2008 3 3 11106.24 open-account my-account set + [ 8416 ] [ + my-account get [ + 2008 3 11 -750 "Need to buy food" , + 2008 3 25 -500 "Going to a party" , + 2008 4 8 -800 "Losing interest in the pony..." , + 2008 4 8 -700 "Buying a rocking horse" , + ] { } make inserting-transactions balance>> round >integer + ] unit-test +] with-scope + +[ + [ 6781 ] [ + "..." 0.07 1 2007 4 10 4398.50 open-account + 2007 10 26 2000 "..." 1array inserting-transactions + 2008 4 10 process-to-date dup balance>> swap unpaid-interest>> + round >integer + ] unit-test +] with-scope diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index c9228bedd5..0ea4bae2b3 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -1,33 +1,69 @@ -USING: accessors calendar kernel money new-slots sequences ; +USING: accessors calendar kernel math money sequences ; IN: bank -MIXIN: policy -TUPLE: simple-policy interest-rate ; -INSTANCE: simple-policy policy -C: simple-policy +TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ; -GENERIC: interest-rate ( date account policy -- rate ) -M: simple-policy interest-rate 2nip interest-rate>> ; - -: daily-interest-rate ( date account policy -- rate ) - pick days-in-year >r interest-rate r> / ; - -TUPLE: account name balance transactions ; - -: ( name -- account ) - 0 V{ } clone account construct-boa ; +: ( name interest-rate interest-payment-day opening-date -- account ) + V{ } clone 0 pick account construct-boa ; TUPLE: transaction date amount description ; - C: transaction : >>transaction ( account transaction -- account ) over transactions>> push ; -: open-account ( date opening-balance name -- account ) - >r "Account Opened" >>transaction ; +: total ( transactions -- balance ) + 0 [ amount>> + ] reduce ; -: open-account-now ( opening-balance name -- account ) - now -rot open-account ; +: balance>> ( account -- balance ) transactions>> total ; +: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account ) + >r [ ] keep r> "Account Opened" >>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 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 ; From bd548d542347aceb76fda026bed71c2234e13ea4 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sun, 27 Apr 2008 22:36:42 +1000 Subject: [PATCH 15/24] add openal.waves to generate tones, and code to play morse code --- extra/morse/morse-docs.factor | 4 ++ extra/morse/morse-tests.factor | 2 + extra/morse/morse.factor | 69 +++++++++++++++++++++++---- extra/openal/openal.factor | 8 +++- extra/openal/waves/waves-tests.factor | 5 ++ extra/openal/waves/waves.factor | 53 ++++++++++++++++++++ 6 files changed, 130 insertions(+), 11 deletions(-) create mode 100644 extra/openal/waves/waves-tests.factor create mode 100644 extra/openal/waves/waves.factor diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index c11ba23db7..31fc7f34c2 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -23,3 +23,7 @@ HELP: morse> { $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } } { $description "Translates morse code into ASCII text" } { $see-also >morse morse>ch } ; + +HELP: play-as-morse +{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } } +{ $description "Plays a string as morse code" } diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index 97efe1afb4..c87fa483e3 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -9,3 +9,5 @@ USING: arrays morse strings tools.test ; [ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test [ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test [ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test +[ ] [ "sos" 0.075 play-as-morse ] unit-test +[ ] [ "Factor rocks!" 0.05 play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index f493951ed5..d0b9e4003a 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: assocs hashtables kernel lazy-lists namespaces openal -parser-combinators promises sequences strings unicode.case ; +USING: assocs combinators hashtables kernel lazy-lists math namespaces +openal openal.waves parser-combinators promises sequences strings symbols +unicode.case ; IN: morse <+> ; @@ -123,3 +124,51 @@ PRIVATE> ] map >string ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ; +r 8 22000 880 r> send-buffer* ; + +: silent-buffer ( seconds -- id ) + 8 22000 rot send-buffer* ; + +: make-buffers ( unit-length -- ) + { + [ sine-buffer dot-buffer set ] + [ 3 * sine-buffer dash-buffer set ] + [ silent-buffer intra-char-gap-buffer set ] + [ 3 * silent-buffer letter-gap-buffer set ] + } cleave ; + +: playing-morse ( quot unit-length -- ) + [ + init-openal 1 gen-sources first source set make-buffers + call + source get source-play + ] with-scope ; + +: play-char ( ch -- ) + [ intra-char-gap ] [ + { + { dot-char [ dot ] } + { dash-char [ dash ] } + { word-gap-char [ intra-char-gap ] } + } case + ] interleave ; + +PRIVATE> + +: play-as-morse ( str unit-length -- ) + [ + [ letter-gap ] [ ch>morse play-char ] interleave + ] swap playing-morse ; + diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index ff67a30ea3..c0a79d8353 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel alien system combinators alien.syntax namespaces +USING: kernel arrays alien system combinators alien.syntax namespaces alien.c-types sequences vocabs.loader shuffle combinators.lib openal.backend ; IN: openal @@ -266,6 +266,12 @@ os macosx? "openal.macosx" "openal.other" ? require gen-buffer dup rot load-wav-file [ alBufferData ] 4keep alutUnloadWAV ; +: queue-buffers ( source buffers -- ) + [ length ] [ >c-uint-array ] bi alSourceQueueBuffers ; + +: queue-buffer ( source buffer -- ) + 1array queue-buffers ; + : set-source-param ( source param value -- ) alSourcei ; diff --git a/extra/openal/waves/waves-tests.factor b/extra/openal/waves/waves-tests.factor new file mode 100644 index 0000000000..b295283aac --- /dev/null +++ b/extra/openal/waves/waves-tests.factor @@ -0,0 +1,5 @@ +USING: kernel openal openal.waves sequences tools.test ; +IN: openal.waves.tests + + +[ ] [ 8 22000 440 1 play-sine-wave ] unit-test diff --git a/extra/openal/waves/waves.factor b/extra/openal/waves/waves.factor new file mode 100644 index 0000000000..abe9f8fb69 --- /dev/null +++ b/extra/openal/waves/waves.factor @@ -0,0 +1,53 @@ +USING: accessors alien.c-types combinators kernel locals math +math.constants math.functions math.ranges openal sequences ; +IN: openal.waves + +TUPLE: buffer bits channels sample-freq seq id ; + +: ( bits sample-freq seq -- buffer ) + ! defaults to 1 channel + 1 -rot gen-buffer buffer boa ; + +: buffer-format ( buffer -- format ) + dup buffer-channels 1 = swap buffer-bits 8 = [ + AL_FORMAT_MONO8 AL_FORMAT_STEREO8 + ] [ + AL_FORMAT_MONO16 AL_FORMAT_STEREO16 + ] if ? ; + +: buffer-data ( buffer -- data size ) + #! 8 bit data is integers between 0 and 255, + #! 16 bit data is integers between -32768 and 32768 + #! size is in bytes + [ seq>> ] [ bits>> ] bi 8 = [ + [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi + ] [ + [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi + ] if ; + +: send-buffer ( buffer -- ) + { [ id>> ] [ buffer-format ] [ buffer-data ] [ sample-freq>> ] } cleave + alBufferData ; + +: send-buffer* ( buffer -- id ) + [ send-buffer ] [ id>> ] bi ; + +: (sine-wave-seq) ( samples/wave n-samples -- seq ) + pi 2 * rot / [ * sin ] curry map ; + +: sine-wave-seq ( sample-freq freq seconds -- seq ) + pick * >integer [ / ] dip (sine-wave-seq) ; + +: ( bits sample-freq freq seconds -- buffer ) + >r dupd r> sine-wave-seq ; + +: ( bits sample-freq seconds -- buffer ) + dupd * >integer [ drop 0 ] map ; + +: play-sine-wave ( bits sample-freq freq seconds -- ) + init-openal + send-buffer* + 1 gen-sources first + [ AL_BUFFER rot set-source-param ] [ source-play ] bi + check-error ; + From 21c50fefe0d8f2584ff06ddcdcb30ebcd58c61fc Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 28 Apr 2008 12:17:08 +1000 Subject: [PATCH 16/24] fix morse-docs, and add authors.txt --- extra/morse/authors.txt | 1 + extra/morse/morse-docs.factor | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 extra/morse/authors.txt diff --git a/extra/morse/authors.txt b/extra/morse/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/morse/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index 31fc7f34c2..f31b741c85 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -26,4 +26,4 @@ HELP: morse> HELP: play-as-morse { $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } } -{ $description "Plays a string as morse code" } +{ $description "Plays a string as morse code" } ; From aa0daed072ca418bad4e47526c00edea6dce9481 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 28 Apr 2008 13:44:46 +1000 Subject: [PATCH 17/24] update tangle and semantic-db for latest changes to factor --- extra/semantic-db/authors.txt | 1 + extra/semantic-db/semantic-db.factor | 6 +++--- extra/tangle/authors.txt | 1 + extra/tangle/html/html.factor | 4 ++-- extra/tangle/tangle.factor | 8 ++++---- 5 files changed, 11 insertions(+), 9 deletions(-) create mode 100644 extra/semantic-db/authors.txt create mode 100644 extra/tangle/authors.txt diff --git a/extra/semantic-db/authors.txt b/extra/semantic-db/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/semantic-db/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 51bd94d61c..2451d73acb 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. 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 +continuations db db.tuples db.types db.sqlite kernel math +math.parser namespaces parser sets sequences sequences.deep sequences.lib strings words ; IN: semantic-db @@ -28,7 +28,7 @@ node "node" TUPLE: arc id subject object relation ; : ( subject object relation -- arc ) - arc construct-empty swap >>relation swap >>object swap >>subject ; + arc new swap >>relation swap >>object swap >>subject ; : ( id -- arc ) arc new swap >>id ; diff --git a/extra/tangle/authors.txt b/extra/tangle/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tangle/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tangle/html/html.factor b/extra/tangle/html/html.factor index 9c55b66528..fc604f4d46 100644 --- a/extra/tangle/html/html.factor +++ b/extra/tangle/html/html.factor @@ -7,11 +7,11 @@ TUPLE: element attributes ; TUPLE: ulist < element items ; : ( items -- element ) - H{ } clone swap ulist construct-boa ; + H{ } clone swap ulist boa ; TUPLE: link < element href text ; : ( href text -- element ) - H{ } clone -rot link construct-boa ; + H{ } clone -rot link boa ; GENERIC: >html ( element -- str ) diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index cbd3b94058..c6a1faa27b 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -1,6 +1,6 @@ ! 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 ; +USING: accessors assocs db db.sqlite db.postgresql http.server http.server.actions io kernel namespaces semantic-db sequences strings ; IN: tangle GENERIC: render* ( content templater -- output ) @@ -20,7 +20,7 @@ TUPLE: sqlite-tangle ; TUPLE: postgres-tangle ; : make-tangle ( db templater type -- tangle ) - construct-empty [ ] dip tuck set-delegate ; + new [ ] dip tuck set-delegate ; : ( db templater -- tangle ) sqlite-tangle make-tangle ; : ( db templater -- tangle ) postgres-tangle make-tangle ; @@ -40,8 +40,8 @@ M: postgres-tangle new-db ( tangle args -- tangle ) TUPLE: node-responder tangle ; C: node-responder -M: node-responder call-responder ( path responder -- response ) - "text/plain" nip request-params +M: node-responder call-responder* ( path responder -- response ) + "text/plain" nip params get [ "node-id" swap at* [ >>body ] [ drop ] if ] when* nip ; : test-tangle ( -- ) From 23608c219f02a83c07cebfff06a535e0a3a5131e Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 28 Apr 2008 14:21:48 +1000 Subject: [PATCH 18/24] update factor.vim for latest changes to vocabs --- extra/bank/authors.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/bank/authors.txt diff --git a/extra/bank/authors.txt b/extra/bank/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/bank/authors.txt @@ -0,0 +1 @@ +Alex Chapman From ffd3ae635d644a260e4c8c4ca73646836b1d2577 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 28 Apr 2008 14:23:16 +1000 Subject: [PATCH 19/24] update factor.vim (not sure what happened with that last commit) --- misc/factor.vim | 14 +++++++------- misc/factor.vim.fgen | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/misc/factor.vim b/misc/factor.vim index 93ce3d6bd5..d1c46cee0b 100644 --- a/misc/factor.vim +++ b/misc/factor.vim @@ -1,7 +1,7 @@ " Vim syntax file " Language: factor " Maintainer: Alex Chapman -" Last Change: 2007 Jan 18 +" Last Change: 2008 Apr 28 " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded @@ -48,17 +48,17 @@ syn keyword factorCompileDirective inline foldable parsing " kernel vocab keywords -syn keyword factorKeyword or construct-delegate set-slots tuck while wrapper nip hashcode wrapper? both? callstack>array die dupd set-delegate callstack callstack? 3dup pick curry build >boolean ?if clone eq? = ? swapd call-clear 2over 2keep 3keep construct general-t clear 2dup when not tuple? 3compose dup call object wrapped unless* if* 2apply >r curry-quot drop when* retainstack -rot delegate with 3slip construct-boa slip compose-first compose-second 3drop construct-empty either? curry? datastack compare curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if <=> unless compose? tuple keep 2curry object? equal? set-datastack 2slip 2drop most null r> set-callstack dip xor rot -roll -syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc union search-alist assoc-like key? update at* assoc-empty? at+ set-at assoc-all? assoc-hashcode intersect change-at assoc-each assoc-subset values rename-at value-at (assoc-stack) at cache assoc>map assoc-contains? assoc assoc-map assoc-pusher diff (assoc>map) assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute delete-at assoc-find keys -syn keyword factorKeyword case dispatch-case-quot with-datastack alist>quot dispatch-case hash-case-table hash-case-quot no-cond no-case? cond distribute-buckets (distribute-buckets) contiguous-range? cond>quot no-cond? no-case recursive-hashcode linear-case-quot hash-dispatch-quot case>quot -syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 before? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? after? fixnum before=? bignum sq neg denominator [-] (all-integers?) times find-last-integer (each-integer) bit? * + - / >= bitand find-integer complex < real > log2 integer? max number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift between? float 1+ 1- min fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator after=? /f -syn keyword factorKeyword slice-to append left-trim clone-like 3sequence set-column-seq map-as reversed pad-left cut* nth sequence slice? tail-slice empty? tail* member? unclip virtual-sequence? set-length last-index* drop-prefix bounds-error? set-slice-seq set-column-col seq-diff map start open-slice midpoint@ add* set-immutable-seq move-forward fourth delete set-slice-to all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) column? reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice index* move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right concat find* set-slice-from flip sum find-last* immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice column-seq sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find column remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth second change-each join set-repetition-len all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index seq-intersect push-if 2all? lengthen column-col joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first bounds-error add bounds-error-seq bounds-error-index unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice sum-lengths new 2each head* infimum subset slice-error subseq replace-slice repetition push trim sequence-hashcode mismatch +syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple +syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-contains? assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys +syn keyword factorKeyword case dispatch-case-quot with-datastack no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot +syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f +syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth second change-each join set-repetition-len all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc syn keyword factorKeyword 3array >array 4array pair? array pair 2array 1array resize-array array? syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln syn keyword factorKeyword resize-string >string 1string string string? syn keyword factorKeyword vector? ?push vector >vector 1vector -syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation ifcc continuation-name set-restart-continuation ignore-errors continuation-retain continue restart-continuation with-disposal set-continuation-catch restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts +syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue restart-continuation with-disposal set-continuation-catch set-condition-error restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal diff --git a/misc/factor.vim.fgen b/misc/factor.vim.fgen index 7bcba78cde..b0d61b8dd0 100644 --- a/misc/factor.vim.fgen +++ b/misc/factor.vim.fgen @@ -2,7 +2,7 @@ %>" Vim syntax file " Language: factor " Maintainer: Alex Chapman -" Last Change: 2007 Jan 18 +" Last Change: 2008 Apr 28 " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded From 4300eeaa89b342e5b6e97d66e03f4f1a8874dfae Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 28 Apr 2008 14:24:30 +1000 Subject: [PATCH 20/24] bank account simulator --- extra/bank/bank.factor | 6 +++--- extra/bank/summary.txt | 1 + 2 files changed, 4 insertions(+), 3 deletions(-) create mode 100644 extra/bank/summary.txt diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index 0ea4bae2b3..35d1337afc 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -1,10 +1,10 @@ -USING: accessors calendar kernel math money sequences ; +USING: accessors calendar kernel math math.order money sequences ; IN: bank TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ; : ( name interest-rate interest-payment-day opening-date -- account ) - V{ } clone 0 pick account construct-boa ; + V{ } clone 0 pick account boa ; TUPLE: transaction date amount description ; C: transaction @@ -29,7 +29,7 @@ C: transaction : before? ( date date -- ? ) <=> 0 < ; : transactions-on-date ( account date -- transactions ) - [ before? ] curry subset ; + [ before? ] curry filter ; : balance-on-date ( account date -- balance ) transactions-on-date total ; diff --git a/extra/bank/summary.txt b/extra/bank/summary.txt new file mode 100644 index 0000000000..efd88787a5 --- /dev/null +++ b/extra/bank/summary.txt @@ -0,0 +1 @@ +Bank account simulator for compound interest calculated daily and paid monthly From 19022db77fc214627f619a09ab9738c7e9b78167 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 28 Apr 2008 14:30:49 +1000 Subject: [PATCH 21/24] deleting unfinished code from this branch --- extra/new-graphs/new-graphs.factor | 21 --------------------- 1 file changed, 21 deletions(-) delete mode 100644 extra/new-graphs/new-graphs.factor diff --git a/extra/new-graphs/new-graphs.factor b/extra/new-graphs/new-graphs.factor deleted file mode 100644 index b82ed8a22d..0000000000 --- a/extra/new-graphs/new-graphs.factor +++ /dev/null @@ -1,21 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel new-slots sequences vectors ; -IN: new-graphs - -TUPLE: graph edges ; -TUPLE: digraph ; -TUPLE: undigraph ; - -: ( -- graph ) - H{ } clone graph construct-boa H{ } clone over set-delegate ; - -: ( -- graph ) - digraph construct-empty tuck set-delegate ; - -: ( -- graph ) - undigraph construct-empty tuck set-delegate ; - -GENERIC: add-vertex ( key value graph -- ) -M: graph add-vertex ( key value digraph -- ) set-at ; - From ce2412c4c84f15a01f66a20d5a47f6d9bb47b494 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 1 May 2008 10:11:19 +1000 Subject: [PATCH 22/24] early tangle working with latest git --- extra/semantic-db/semantic-db.factor | 6 ++--- extra/tangle/tangle.factor | 36 ++++++++-------------------- 2 files changed, 13 insertions(+), 29 deletions(-) diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 22b08322d2..1c3dd2d54e 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -15,7 +15,7 @@ node "node" { "content" "content" TEXT } } define-persistent -: delete-node ( node -- ) delete-tuple ; +: delete-node ( node -- ) delete-tuples ; : create-node ( content -- node ) f swap dup insert-tuple ; : load-node ( id -- node ) f select-tuple ; @@ -33,7 +33,7 @@ TUPLE: arc id subject object relation ; : ( id -- arc ) arc new swap >>id ; -: delete-arc ( arc -- ) delete-tuple ; +: delete-arc ( arc -- ) delete-tuples ; : create-arc ( subject object relation -- ) [ id>> ] 3apply insert-tuple ; @@ -76,7 +76,7 @@ TUPLE: arc id subject object relation ; arc "arc" { - { "id" "id" +native-id+ +autoincrement+ } + { "id" "id" +db-assigned-id+ +autoincrement+ } { "relation" "relation" INTEGER +not-null+ } { "subject" "subject" INTEGER +not-null+ } { "object" "object" INTEGER +not-null+ } diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index c6a1faa27b..9dad155777 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs db db.sqlite db.postgresql http.server http.server.actions io kernel namespaces semantic-db sequences strings ; +USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions io kernel math.parser namespaces semantic-db sequences strings ; IN: tangle GENERIC: render* ( content templater -- output ) @@ -13,37 +13,21 @@ M: echo-template render* drop ; ! METHOD: render* { string echo-template } drop ; M: object render render* write ; -TUPLE: tangle db templater ; +TUPLE: tangle db seq templater ; C: tangle -TUPLE: sqlite-tangle ; -TUPLE: postgres-tangle ; - -: make-tangle ( db templater type -- tangle ) - new [ ] dip tuck set-delegate ; - -: ( db templater -- tangle ) sqlite-tangle make-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 ; + [ [ db>> ] [ seq>> ] bi ] dip with-db ; TUPLE: node-responder tangle ; C: node-responder +: node-response ( responder id -- responder ) + load-node [ node-content ] [ "Unknown node" ] if* >>body ; + M: node-responder call-responder* ( path responder -- response ) - "text/plain" nip params get - [ "node-id" swap at* [ >>body ] [ drop ] if ] when* nip ; - -: test-tangle ( -- ) - f f main-responder set ; + dup tangle>> [ + "text/plain" nip request get request-params + [ "node-id" swap at* [ string>number node-response ] [ drop ] if ] when* nip + ] with-tangle ; From b7291869866bf8b4148cd19c1963f179d72b5d37 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 1 May 2008 11:49:55 +1000 Subject: [PATCH 23/24] morse: add a default speed to play at --- extra/morse/morse-tests.factor | 2 +- extra/morse/morse.factor | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index c87fa483e3..dabb93579d 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -10,4 +10,4 @@ USING: arrays morse strings tools.test ; [ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test [ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test [ ] [ "sos" 0.075 play-as-morse ] unit-test -[ ] [ "Factor rocks!" 0.05 play-as-morse ] unit-test +[ ] [ "Factor rocks!" play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index d0b9e4003a..ecade14cdb 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -167,8 +167,10 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ; PRIVATE> -: play-as-morse ( str unit-length -- ) +: play-as-morse* ( str unit-length -- ) [ [ letter-gap ] [ ch>morse play-char ] interleave ] swap playing-morse ; +: play-as-morse ( str -- ) + 0.05 play-as-morse* ; From 06d7edbf964a5222653bf4a5f98ead93b721f0f3 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 2 May 2008 15:46:21 +1000 Subject: [PATCH 24/24] tangle: early ajax interface to create and view nodes --- extra/semantic-db/semantic-db-tests.factor | 1 + extra/semantic-db/semantic-db.factor | 3 ++ extra/tangle/path/path.factor | 11 ++-- extra/tangle/resources/jquery-1.2.3.min.js | 32 ++++++++++++ extra/tangle/resources/weave.html | 18 +++++++ extra/tangle/resources/weave.js | 27 ++++++++++ extra/tangle/sandbox/sandbox.factor | 18 +++++++ extra/tangle/summary.txt | 1 + extra/tangle/tangle-tests.factor | 6 +-- extra/tangle/tangle.factor | 60 ++++++++++++++++++---- 10 files changed, 162 insertions(+), 15 deletions(-) create mode 100644 extra/tangle/resources/jquery-1.2.3.min.js create mode 100644 extra/tangle/resources/weave.html create mode 100644 extra/tangle/resources/weave.js create mode 100644 extra/tangle/sandbox/sandbox.factor create mode 100644 extra/tangle/summary.txt diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 8fec6d5cbb..484af741aa 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -18,6 +18,7 @@ test-db [ [ 3 ] [ "third node" create-node id>> ] unit-test [ 4 ] [ f create-node id>> ] unit-test [ ] [ 1 f 2 f 3 f create-arc ] unit-test + [ { 1 2 3 4 } ] [ all-node-ids ] unit-test ] with-db delete-db test-db [ diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 1c3dd2d54e..3044c8872f 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -112,6 +112,9 @@ arc "arc" : param ( value key type -- param ) swapd ; +: all-node-ids ( -- seq ) + f "select n.id from node n" results [ first string>number ] map ; + : subjects-with-cor ( content object relation -- sql-results ) [ id>> ] bi@ [ diff --git a/extra/tangle/path/path.factor b/extra/tangle/path/path.factor index e7cf3de967..b4151ce1c2 100644 --- a/extra/tangle/path/path.factor +++ b/extra/tangle/path/path.factor @@ -27,9 +27,11 @@ RELATION: in-directory : (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 ; + ensure-root swap [ (path>node) ] each ; + +: path>file ( path -- file ) + path>node [ has-filename-subjects ?first ] [ f ] if* ; : (node>path) ( root seq node -- seq ) pick over node= [ @@ -45,7 +47,10 @@ USE: tools.walker : node>path* ( root node -- path ) V{ } clone swap (node>path) dup empty? - [ drop f ] [ "/" join ] if ; + [ drop f ] [ ] if ; : node>path ( node -- path ) ensure-root swap node>path* ; + +: file>path ( node -- path ) + has-filename-objects ?first [ node>path ] [ f ] if* ; diff --git a/extra/tangle/resources/jquery-1.2.3.min.js b/extra/tangle/resources/jquery-1.2.3.min.js new file mode 100644 index 0000000000..3747929d8b --- /dev/null +++ b/extra/tangle/resources/jquery-1.2.3.min.js @@ -0,0 +1,32 @@ +/* + * jQuery 1.2.3 - New Wave Javascript + * + * Copyright (c) 2008 John Resig (jquery.com) + * Dual licensed under the MIT (MIT-LICENSE.txt) + * and GPL (GPL-LICENSE.txt) licenses. + * + * $Date: 2008-02-06 00:21:25 -0500 (Wed, 06 Feb 2008) $ + * $Rev: 4663 $ + */ +(function(){if(window.jQuery)var _jQuery=window.jQuery;var jQuery=window.jQuery=function(selector,context){return new jQuery.prototype.init(selector,context);};if(window.$)var _$=window.$;window.$=jQuery;var quickExpr=/^[^<]*(<(.|\s)+>)[^>]*$|^#(\w+)$/;var isSimple=/^.[^:#\[\.]*$/;jQuery.fn=jQuery.prototype={init:function(selector,context){selector=selector||document;if(selector.nodeType){this[0]=selector;this.length=1;return this;}else if(typeof selector=="string"){var match=quickExpr.exec(selector);if(match&&(match[1]||!context)){if(match[1])selector=jQuery.clean([match[1]],context);else{var elem=document.getElementById(match[3]);if(elem)if(elem.id!=match[3])return jQuery().find(selector);else{this[0]=elem;this.length=1;return this;}else +selector=[];}}else +return new jQuery(context).find(selector);}else if(jQuery.isFunction(selector))return new jQuery(document)[jQuery.fn.ready?"ready":"load"](selector);return this.setArray(selector.constructor==Array&&selector||(selector.jquery||selector.length&&selector!=window&&!selector.nodeType&&selector[0]!=undefined&&selector[0].nodeType)&&jQuery.makeArray(selector)||[selector]);},jquery:"1.2.3",size:function(){return this.length;},length:0,get:function(num){return num==undefined?jQuery.makeArray(this):this[num];},pushStack:function(elems){var ret=jQuery(elems);ret.prevObject=this;return ret;},setArray:function(elems){this.length=0;Array.prototype.push.apply(this,elems);return this;},each:function(callback,args){return jQuery.each(this,callback,args);},index:function(elem){var ret=-1;this.each(function(i){if(this==elem)ret=i;});return ret;},attr:function(name,value,type){var options=name;if(name.constructor==String)if(value==undefined)return this.length&&jQuery[type||"attr"](this[0],name)||undefined;else{options={};options[name]=value;}return this.each(function(i){for(name in options)jQuery.attr(type?this.style:this,name,jQuery.prop(this,options[name],type,i,name));});},css:function(key,value){if((key=='width'||key=='height')&&parseFloat(value)<0)value=undefined;return this.attr(key,value,"curCSS");},text:function(text){if(typeof text!="object"&&text!=null)return this.empty().append((this[0]&&this[0].ownerDocument||document).createTextNode(text));var ret="";jQuery.each(text||this,function(){jQuery.each(this.childNodes,function(){if(this.nodeType!=8)ret+=this.nodeType!=1?this.nodeValue:jQuery.fn.text([this]);});});return ret;},wrapAll:function(html){if(this[0])jQuery(html,this[0].ownerDocument).clone().insertBefore(this[0]).map(function(){var elem=this;while(elem.firstChild)elem=elem.firstChild;return elem;}).append(this);return this;},wrapInner:function(html){return this.each(function(){jQuery(this).contents().wrapAll(html);});},wrap:function(html){return this.each(function(){jQuery(this).wrapAll(html);});},append:function(){return this.domManip(arguments,true,false,function(elem){if(this.nodeType==1)this.appendChild(elem);});},prepend:function(){return this.domManip(arguments,true,true,function(elem){if(this.nodeType==1)this.insertBefore(elem,this.firstChild);});},before:function(){return this.domManip(arguments,false,false,function(elem){this.parentNode.insertBefore(elem,this);});},after:function(){return this.domManip(arguments,false,true,function(elem){this.parentNode.insertBefore(elem,this.nextSibling);});},end:function(){return this.prevObject||jQuery([]);},find:function(selector){var elems=jQuery.map(this,function(elem){return jQuery.find(selector,elem);});return this.pushStack(/[^+>] [^+>]/.test(selector)||selector.indexOf("..")>-1?jQuery.unique(elems):elems);},clone:function(events){var ret=this.map(function(){if(jQuery.browser.msie&&!jQuery.isXMLDoc(this)){var clone=this.cloneNode(true),container=document.createElement("div");container.appendChild(clone);return jQuery.clean([container.innerHTML])[0];}else +return this.cloneNode(true);});var clone=ret.find("*").andSelf().each(function(){if(this[expando]!=undefined)this[expando]=null;});if(events===true)this.find("*").andSelf().each(function(i){if(this.nodeType==3)return;var events=jQuery.data(this,"events");for(var type in events)for(var handler in events[type])jQuery.event.add(clone[i],type,events[type][handler],events[type][handler].data);});return ret;},filter:function(selector){return this.pushStack(jQuery.isFunction(selector)&&jQuery.grep(this,function(elem,i){return selector.call(elem,i);})||jQuery.multiFilter(selector,this));},not:function(selector){if(selector.constructor==String)if(isSimple.test(selector))return this.pushStack(jQuery.multiFilter(selector,this,true));else +selector=jQuery.multiFilter(selector,this);var isArrayLike=selector.length&&selector[selector.length-1]!==undefined&&!selector.nodeType;return this.filter(function(){return isArrayLike?jQuery.inArray(this,selector)<0:this!=selector;});},add:function(selector){return!selector?this:this.pushStack(jQuery.merge(this.get(),selector.constructor==String?jQuery(selector).get():selector.length!=undefined&&(!selector.nodeName||jQuery.nodeName(selector,"form"))?selector:[selector]));},is:function(selector){return selector?jQuery.multiFilter(selector,this).length>0:false;},hasClass:function(selector){return this.is("."+selector);},val:function(value){if(value==undefined){if(this.length){var elem=this[0];if(jQuery.nodeName(elem,"select")){var index=elem.selectedIndex,values=[],options=elem.options,one=elem.type=="select-one";if(index<0)return null;for(var i=one?index:0,max=one?index+1:options.length;i=0||jQuery.inArray(this.name,value)>=0);else if(jQuery.nodeName(this,"select")){var values=value.constructor==Array?value:[value];jQuery("option",this).each(function(){this.selected=(jQuery.inArray(this.value,values)>=0||jQuery.inArray(this.text,values)>=0);});if(!values.length)this.selectedIndex=-1;}else +this.value=value;});},html:function(value){return value==undefined?(this.length?this[0].innerHTML:null):this.empty().append(value);},replaceWith:function(value){return this.after(value).remove();},eq:function(i){return this.slice(i,i+1);},slice:function(){return this.pushStack(Array.prototype.slice.apply(this,arguments));},map:function(callback){return this.pushStack(jQuery.map(this,function(elem,i){return callback.call(elem,i,elem);}));},andSelf:function(){return this.add(this.prevObject);},data:function(key,value){var parts=key.split(".");parts[1]=parts[1]?"."+parts[1]:"";if(value==null){var data=this.triggerHandler("getData"+parts[1]+"!",[parts[0]]);if(data==undefined&&this.length)data=jQuery.data(this[0],key);return data==null&&parts[1]?this.data(parts[0]):data;}else +return this.trigger("setData"+parts[1]+"!",[parts[0],value]).each(function(){jQuery.data(this,key,value);});},removeData:function(key){return this.each(function(){jQuery.removeData(this,key);});},domManip:function(args,table,reverse,callback){var clone=this.length>1,elems;return this.each(function(){if(!elems){elems=jQuery.clean(args,this.ownerDocument);if(reverse)elems.reverse();}var obj=this;if(table&&jQuery.nodeName(this,"table")&&jQuery.nodeName(elems[0],"tr"))obj=this.getElementsByTagName("tbody")[0]||this.appendChild(this.ownerDocument.createElement("tbody"));var scripts=jQuery([]);jQuery.each(elems,function(){var elem=clone?jQuery(this).clone(true)[0]:this;if(jQuery.nodeName(elem,"script")){scripts=scripts.add(elem);}else{if(elem.nodeType==1)scripts=scripts.add(jQuery("script",elem).remove());callback.call(obj,elem);}});scripts.each(evalScript);});}};jQuery.prototype.init.prototype=jQuery.prototype;function evalScript(i,elem){if(elem.src)jQuery.ajax({url:elem.src,async:false,dataType:"script"});else +jQuery.globalEval(elem.text||elem.textContent||elem.innerHTML||"");if(elem.parentNode)elem.parentNode.removeChild(elem);}jQuery.extend=jQuery.fn.extend=function(){var target=arguments[0]||{},i=1,length=arguments.length,deep=false,options;if(target.constructor==Boolean){deep=target;target=arguments[1]||{};i=2;}if(typeof target!="object"&&typeof target!="function")target={};if(length==1){target=this;i=0;}for(;i-1;}},swap:function(elem,options,callback){var old={};for(var name in options){old[name]=elem.style[name];elem.style[name]=options[name];}callback.call(elem);for(var name in options)elem.style[name]=old[name];},css:function(elem,name,force){if(name=="width"||name=="height"){var val,props={position:"absolute",visibility:"hidden",display:"block"},which=name=="width"?["Left","Right"]:["Top","Bottom"];function getWH(){val=name=="width"?elem.offsetWidth:elem.offsetHeight;var padding=0,border=0;jQuery.each(which,function(){padding+=parseFloat(jQuery.curCSS(elem,"padding"+this,true))||0;border+=parseFloat(jQuery.curCSS(elem,"border"+this+"Width",true))||0;});val-=Math.round(padding+border);}if(jQuery(elem).is(":visible"))getWH();else +jQuery.swap(elem,props,getWH);return Math.max(0,val);}return jQuery.curCSS(elem,name,force);},curCSS:function(elem,name,force){var ret;function color(elem){if(!jQuery.browser.safari)return false;var ret=document.defaultView.getComputedStyle(elem,null);return!ret||ret.getPropertyValue("color")=="";}if(name=="opacity"&&jQuery.browser.msie){ret=jQuery.attr(elem.style,"opacity");return ret==""?"1":ret;}if(jQuery.browser.opera&&name=="display"){var save=elem.style.outline;elem.style.outline="0 solid black";elem.style.outline=save;}if(name.match(/float/i))name=styleFloat;if(!force&&elem.style&&elem.style[name])ret=elem.style[name];else if(document.defaultView&&document.defaultView.getComputedStyle){if(name.match(/float/i))name="float";name=name.replace(/([A-Z])/g,"-$1").toLowerCase();var getComputedStyle=document.defaultView.getComputedStyle(elem,null);if(getComputedStyle&&!color(elem))ret=getComputedStyle.getPropertyValue(name);else{var swap=[],stack=[];for(var a=elem;a&&color(a);a=a.parentNode)stack.unshift(a);for(var i=0;i]*?)\/>/g,function(all,front,tag){return tag.match(/^(abbr|br|col|img|input|link|meta|param|hr|area|embed)$/i)?all:front+">";});var tags=jQuery.trim(elem).toLowerCase(),div=context.createElement("div");var wrap=!tags.indexOf("",""]||!tags.indexOf("",""]||tags.match(/^<(thead|tbody|tfoot|colg|cap)/)&&[1,"","
"]||!tags.indexOf("",""]||(!tags.indexOf("",""]||!tags.indexOf("",""]||jQuery.browser.msie&&[1,"div
","
"]||[0,"",""];div.innerHTML=wrap[1]+elem+wrap[2];while(wrap[0]--)div=div.lastChild;if(jQuery.browser.msie){var tbody=!tags.indexOf(""&&tags.indexOf("=0;--j)if(jQuery.nodeName(tbody[j],"tbody")&&!tbody[j].childNodes.length)tbody[j].parentNode.removeChild(tbody[j]);if(/^\s/.test(elem))div.insertBefore(context.createTextNode(elem.match(/^\s*/)[0]),div.firstChild);}elem=jQuery.makeArray(div.childNodes);}if(elem.length===0&&(!jQuery.nodeName(elem,"form")&&!jQuery.nodeName(elem,"select")))return;if(elem[0]==undefined||jQuery.nodeName(elem,"form")||elem.options)ret.push(elem);else +ret=jQuery.merge(ret,elem);});return ret;},attr:function(elem,name,value){if(!elem||elem.nodeType==3||elem.nodeType==8)return undefined;var fix=jQuery.isXMLDoc(elem)?{}:jQuery.props;if(name=="selected"&&jQuery.browser.safari)elem.parentNode.selectedIndex;if(fix[name]){if(value!=undefined)elem[fix[name]]=value;return elem[fix[name]];}else if(jQuery.browser.msie&&name=="style")return jQuery.attr(elem.style,"cssText",value);else if(value==undefined&&jQuery.browser.msie&&jQuery.nodeName(elem,"form")&&(name=="action"||name=="method"))return elem.getAttributeNode(name).nodeValue;else if(elem.tagName){if(value!=undefined){if(name=="type"&&jQuery.nodeName(elem,"input")&&elem.parentNode)throw"type property can't be changed";elem.setAttribute(name,""+value);}if(jQuery.browser.msie&&/href|src/.test(name)&&!jQuery.isXMLDoc(elem))return elem.getAttribute(name,2);return elem.getAttribute(name);}else{if(name=="opacity"&&jQuery.browser.msie){if(value!=undefined){elem.zoom=1;elem.filter=(elem.filter||"").replace(/alpha\([^)]*\)/,"")+(parseFloat(value).toString()=="NaN"?"":"alpha(opacity="+value*100+")");}return elem.filter&&elem.filter.indexOf("opacity=")>=0?(parseFloat(elem.filter.match(/opacity=([^)]*)/)[1])/100).toString():"";}name=name.replace(/-([a-z])/ig,function(all,letter){return letter.toUpperCase();});if(value!=undefined)elem[name]=value;return elem[name];}},trim:function(text){return(text||"").replace(/^\s+|\s+$/g,"");},makeArray:function(array){var ret=[];if(typeof array!="array")for(var i=0,length=array.length;i*",this).remove();while(this.firstChild)this.removeChild(this.firstChild);}},function(name,fn){jQuery.fn[name]=function(){return this.each(fn,arguments);};});jQuery.each(["Height","Width"],function(i,name){var type=name.toLowerCase();jQuery.fn[type]=function(size){return this[0]==window?jQuery.browser.opera&&document.body["client"+name]||jQuery.browser.safari&&window["inner"+name]||document.compatMode=="CSS1Compat"&&document.documentElement["client"+name]||document.body["client"+name]:this[0]==document?Math.max(Math.max(document.body["scroll"+name],document.documentElement["scroll"+name]),Math.max(document.body["offset"+name],document.documentElement["offset"+name])):size==undefined?(this.length?jQuery.css(this[0],type):null):this.css(type,size.constructor==String?size:size+"px");};});var chars=jQuery.browser.safari&&parseInt(jQuery.browser.version)<417?"(?:[\\w*_-]|\\\\.)":"(?:[\\w\u0128-\uFFFF*_-]|\\\\.)",quickChild=new RegExp("^>\\s*("+chars+"+)"),quickID=new RegExp("^("+chars+"+)(#)("+chars+"+)"),quickClass=new RegExp("^([#.]?)("+chars+"*)");jQuery.extend({expr:{"":function(a,i,m){return m[2]=="*"||jQuery.nodeName(a,m[2]);},"#":function(a,i,m){return a.getAttribute("id")==m[2];},":":{lt:function(a,i,m){return im[3]-0;},nth:function(a,i,m){return m[3]-0==i;},eq:function(a,i,m){return m[3]-0==i;},first:function(a,i){return i==0;},last:function(a,i,m,r){return i==r.length-1;},even:function(a,i){return i%2==0;},odd:function(a,i){return i%2;},"first-child":function(a){return a.parentNode.getElementsByTagName("*")[0]==a;},"last-child":function(a){return jQuery.nth(a.parentNode.lastChild,1,"previousSibling")==a;},"only-child":function(a){return!jQuery.nth(a.parentNode.lastChild,2,"previousSibling");},parent:function(a){return a.firstChild;},empty:function(a){return!a.firstChild;},contains:function(a,i,m){return(a.textContent||a.innerText||jQuery(a).text()||"").indexOf(m[3])>=0;},visible:function(a){return"hidden"!=a.type&&jQuery.css(a,"display")!="none"&&jQuery.css(a,"visibility")!="hidden";},hidden:function(a){return"hidden"==a.type||jQuery.css(a,"display")=="none"||jQuery.css(a,"visibility")=="hidden";},enabled:function(a){return!a.disabled;},disabled:function(a){return a.disabled;},checked:function(a){return a.checked;},selected:function(a){return a.selected||jQuery.attr(a,"selected");},text:function(a){return"text"==a.type;},radio:function(a){return"radio"==a.type;},checkbox:function(a){return"checkbox"==a.type;},file:function(a){return"file"==a.type;},password:function(a){return"password"==a.type;},submit:function(a){return"submit"==a.type;},image:function(a){return"image"==a.type;},reset:function(a){return"reset"==a.type;},button:function(a){return"button"==a.type||jQuery.nodeName(a,"button");},input:function(a){return/input|select|textarea|button/i.test(a.nodeName);},has:function(a,i,m){return jQuery.find(m[3],a).length;},header:function(a){return/h\d/i.test(a.nodeName);},animated:function(a){return jQuery.grep(jQuery.timers,function(fn){return a==fn.elem;}).length;}}},parse:[/^(\[) *@?([\w-]+) *([!*$^~=]*) *('?"?)(.*?)\4 *\]/,/^(:)([\w-]+)\("?'?(.*?(\(.*?\))?[^(]*?)"?'?\)/,new RegExp("^([:.#]*)("+chars+"+)")],multiFilter:function(expr,elems,not){var old,cur=[];while(expr&&expr!=old){old=expr;var f=jQuery.filter(expr,elems,not);expr=f.t.replace(/^\s*,\s*/,"");cur=not?elems=f.r:jQuery.merge(cur,f.r);}return cur;},find:function(t,context){if(typeof t!="string")return[t];if(context&&context.nodeType!=1&&context.nodeType!=9)return[];context=context||document;var ret=[context],done=[],last,nodeName;while(t&&last!=t){var r=[];last=t;t=jQuery.trim(t);var foundToken=false;var re=quickChild;var m=re.exec(t);if(m){nodeName=m[1].toUpperCase();for(var i=0;ret[i];i++)for(var c=ret[i].firstChild;c;c=c.nextSibling)if(c.nodeType==1&&(nodeName=="*"||c.nodeName.toUpperCase()==nodeName))r.push(c);ret=r;t=t.replace(re,"");if(t.indexOf(" ")==0)continue;foundToken=true;}else{re=/^([>+~])\s*(\w*)/i;if((m=re.exec(t))!=null){r=[];var merge={};nodeName=m[2].toUpperCase();m=m[1];for(var j=0,rl=ret.length;j=0;if(!not&&pass||not&&!pass)tmp.push(r[i]);}return tmp;},filter:function(t,r,not){var last;while(t&&t!=last){last=t;var p=jQuery.parse,m;for(var i=0;p[i];i++){m=p[i].exec(t);if(m){t=t.substring(m[0].length);m[2]=m[2].replace(/\\/g,"");break;}}if(!m)break;if(m[1]==":"&&m[2]=="not")r=isSimple.test(m[3])?jQuery.filter(m[3],r,true).r:jQuery(r).not(m[3]);else if(m[1]==".")r=jQuery.classFilter(r,m[2],not);else if(m[1]=="["){var tmp=[],type=m[3];for(var i=0,rl=r.length;i=0)^not)tmp.push(a);}r=tmp;}else if(m[1]==":"&&m[2]=="nth-child"){var merge={},tmp=[],test=/(-?)(\d*)n((?:\+|-)?\d*)/.exec(m[3]=="even"&&"2n"||m[3]=="odd"&&"2n+1"||!/\D/.test(m[3])&&"0n+"+m[3]||m[3]),first=(test[1]+(test[2]||1))-0,last=test[3]-0;for(var i=0,rl=r.length;i=0)add=true;if(add^not)tmp.push(node);}r=tmp;}else{var fn=jQuery.expr[m[1]];if(typeof fn=="object")fn=fn[m[2]];if(typeof fn=="string")fn=eval("false||function(a,i){return "+fn+";}");r=jQuery.grep(r,function(elem,i){return fn(elem,i,m,r);},not);}}return{r:r,t:t};},dir:function(elem,dir){var matched=[];var cur=elem[dir];while(cur&&cur!=document){if(cur.nodeType==1)matched.push(cur);cur=cur[dir];}return matched;},nth:function(cur,result,dir,elem){result=result||1;var num=0;for(;cur;cur=cur[dir])if(cur.nodeType==1&&++num==result)break;return cur;},sibling:function(n,elem){var r=[];for(;n;n=n.nextSibling){if(n.nodeType==1&&(!elem||n!=elem))r.push(n);}return r;}});jQuery.event={add:function(elem,types,handler,data){if(elem.nodeType==3||elem.nodeType==8)return;if(jQuery.browser.msie&&elem.setInterval!=undefined)elem=window;if(!handler.guid)handler.guid=this.guid++;if(data!=undefined){var fn=handler;handler=function(){return fn.apply(this,arguments);};handler.data=data;handler.guid=fn.guid;}var events=jQuery.data(elem,"events")||jQuery.data(elem,"events",{}),handle=jQuery.data(elem,"handle")||jQuery.data(elem,"handle",function(){var val;if(typeof jQuery=="undefined"||jQuery.event.triggered)return val;val=jQuery.event.handle.apply(arguments.callee.elem,arguments);return val;});handle.elem=elem;jQuery.each(types.split(/\s+/),function(index,type){var parts=type.split(".");type=parts[0];handler.type=parts[1];var handlers=events[type];if(!handlers){handlers=events[type]={};if(!jQuery.event.special[type]||jQuery.event.special[type].setup.call(elem)===false){if(elem.addEventListener)elem.addEventListener(type,handle,false);else if(elem.attachEvent)elem.attachEvent("on"+type,handle);}}handlers[handler.guid]=handler;jQuery.event.global[type]=true;});elem=null;},guid:1,global:{},remove:function(elem,types,handler){if(elem.nodeType==3||elem.nodeType==8)return;var events=jQuery.data(elem,"events"),ret,index;if(events){if(types==undefined||(typeof types=="string"&&types.charAt(0)=="."))for(var type in events)this.remove(elem,type+(types||""));else{if(types.type){handler=types.handler;types=types.type;}jQuery.each(types.split(/\s+/),function(index,type){var parts=type.split(".");type=parts[0];if(events[type]){if(handler)delete events[type][handler.guid];else +for(handler in events[type])if(!parts[1]||events[type][handler].type==parts[1])delete events[type][handler];for(ret in events[type])break;if(!ret){if(!jQuery.event.special[type]||jQuery.event.special[type].teardown.call(elem)===false){if(elem.removeEventListener)elem.removeEventListener(type,jQuery.data(elem,"handle"),false);else if(elem.detachEvent)elem.detachEvent("on"+type,jQuery.data(elem,"handle"));}ret=null;delete events[type];}}});}for(ret in events)break;if(!ret){var handle=jQuery.data(elem,"handle");if(handle)handle.elem=null;jQuery.removeData(elem,"events");jQuery.removeData(elem,"handle");}}},trigger:function(type,data,elem,donative,extra){data=jQuery.makeArray(data||[]);if(type.indexOf("!")>=0){type=type.slice(0,-1);var exclusive=true;}if(!elem){if(this.global[type])jQuery("*").add([window,document]).trigger(type,data);}else{if(elem.nodeType==3||elem.nodeType==8)return undefined;var val,ret,fn=jQuery.isFunction(elem[type]||null),event=!data[0]||!data[0].preventDefault;if(event)data.unshift(this.fix({type:type,target:elem}));data[0].type=type;if(exclusive)data[0].exclusive=true;if(jQuery.isFunction(jQuery.data(elem,"handle")))val=jQuery.data(elem,"handle").apply(elem,data);if(!fn&&elem["on"+type]&&elem["on"+type].apply(elem,data)===false)val=false;if(event)data.shift();if(extra&&jQuery.isFunction(extra)){ret=extra.apply(elem,val==null?data:data.concat(val));if(ret!==undefined)val=ret;}if(fn&&donative!==false&&val!==false&&!(jQuery.nodeName(elem,'a')&&type=="click")){this.triggered=true;try{elem[type]();}catch(e){}}this.triggered=false;}return val;},handle:function(event){var val;event=jQuery.event.fix(event||window.event||{});var parts=event.type.split(".");event.type=parts[0];var handlers=jQuery.data(this,"events")&&jQuery.data(this,"events")[event.type],args=Array.prototype.slice.call(arguments,1);args.unshift(event);for(var j in handlers){var handler=handlers[j];args[0].handler=handler;args[0].data=handler.data;if(!parts[1]&&!event.exclusive||handler.type==parts[1]){var ret=handler.apply(this,args);if(val!==false)val=ret;if(ret===false){event.preventDefault();event.stopPropagation();}}}if(jQuery.browser.msie)event.target=event.preventDefault=event.stopPropagation=event.handler=event.data=null;return val;},fix:function(event){var originalEvent=event;event=jQuery.extend({},originalEvent);event.preventDefault=function(){if(originalEvent.preventDefault)originalEvent.preventDefault();originalEvent.returnValue=false;};event.stopPropagation=function(){if(originalEvent.stopPropagation)originalEvent.stopPropagation();originalEvent.cancelBubble=true;};if(!event.target)event.target=event.srcElement||document;if(event.target.nodeType==3)event.target=originalEvent.target.parentNode;if(!event.relatedTarget&&event.fromElement)event.relatedTarget=event.fromElement==event.target?event.toElement:event.fromElement;if(event.pageX==null&&event.clientX!=null){var doc=document.documentElement,body=document.body;event.pageX=event.clientX+(doc&&doc.scrollLeft||body&&body.scrollLeft||0)-(doc.clientLeft||0);event.pageY=event.clientY+(doc&&doc.scrollTop||body&&body.scrollTop||0)-(doc.clientTop||0);}if(!event.which&&((event.charCode||event.charCode===0)?event.charCode:event.keyCode))event.which=event.charCode||event.keyCode;if(!event.metaKey&&event.ctrlKey)event.metaKey=event.ctrlKey;if(!event.which&&event.button)event.which=(event.button&1?1:(event.button&2?3:(event.button&4?2:0)));return event;},special:{ready:{setup:function(){bindReady();return;},teardown:function(){return;}},mouseenter:{setup:function(){if(jQuery.browser.msie)return false;jQuery(this).bind("mouseover",jQuery.event.special.mouseenter.handler);return true;},teardown:function(){if(jQuery.browser.msie)return false;jQuery(this).unbind("mouseover",jQuery.event.special.mouseenter.handler);return true;},handler:function(event){if(withinElement(event,this))return true;arguments[0].type="mouseenter";return jQuery.event.handle.apply(this,arguments);}},mouseleave:{setup:function(){if(jQuery.browser.msie)return false;jQuery(this).bind("mouseout",jQuery.event.special.mouseleave.handler);return true;},teardown:function(){if(jQuery.browser.msie)return false;jQuery(this).unbind("mouseout",jQuery.event.special.mouseleave.handler);return true;},handler:function(event){if(withinElement(event,this))return true;arguments[0].type="mouseleave";return jQuery.event.handle.apply(this,arguments);}}}};jQuery.fn.extend({bind:function(type,data,fn){return type=="unload"?this.one(type,data,fn):this.each(function(){jQuery.event.add(this,type,fn||data,fn&&data);});},one:function(type,data,fn){return this.each(function(){jQuery.event.add(this,type,function(event){jQuery(this).unbind(event);return(fn||data).apply(this,arguments);},fn&&data);});},unbind:function(type,fn){return this.each(function(){jQuery.event.remove(this,type,fn);});},trigger:function(type,data,fn){return this.each(function(){jQuery.event.trigger(type,data,this,true,fn);});},triggerHandler:function(type,data,fn){if(this[0])return jQuery.event.trigger(type,data,this[0],false,fn);return undefined;},toggle:function(){var args=arguments;return this.click(function(event){this.lastToggle=0==this.lastToggle?1:0;event.preventDefault();return args[this.lastToggle].apply(this,arguments)||false;});},hover:function(fnOver,fnOut){return this.bind('mouseenter',fnOver).bind('mouseleave',fnOut);},ready:function(fn){bindReady();if(jQuery.isReady)fn.call(document,jQuery);else +jQuery.readyList.push(function(){return fn.call(this,jQuery);});return this;}});jQuery.extend({isReady:false,readyList:[],ready:function(){if(!jQuery.isReady){jQuery.isReady=true;if(jQuery.readyList){jQuery.each(jQuery.readyList,function(){this.apply(document);});jQuery.readyList=null;}jQuery(document).triggerHandler("ready");}}});var readyBound=false;function bindReady(){if(readyBound)return;readyBound=true;if(document.addEventListener&&!jQuery.browser.opera)document.addEventListener("DOMContentLoaded",jQuery.ready,false);if(jQuery.browser.msie&&window==top)(function(){if(jQuery.isReady)return;try{document.documentElement.doScroll("left");}catch(error){setTimeout(arguments.callee,0);return;}jQuery.ready();})();if(jQuery.browser.opera)document.addEventListener("DOMContentLoaded",function(){if(jQuery.isReady)return;for(var i=0;i=0){var selector=url.slice(off,url.length);url=url.slice(0,off);}callback=callback||function(){};var type="GET";if(params)if(jQuery.isFunction(params)){callback=params;params=null;}else{params=jQuery.param(params);type="POST";}var self=this;jQuery.ajax({url:url,type:type,dataType:"html",data:params,complete:function(res,status){if(status=="success"||status=="notmodified")self.html(selector?jQuery("
").append(res.responseText.replace(//g,"")).find(selector):res.responseText);self.each(callback,[res.responseText,status,res]);}});return this;},serialize:function(){return jQuery.param(this.serializeArray());},serializeArray:function(){return this.map(function(){return jQuery.nodeName(this,"form")?jQuery.makeArray(this.elements):this;}).filter(function(){return this.name&&!this.disabled&&(this.checked||/select|textarea/i.test(this.nodeName)||/text|hidden|password/i.test(this.type));}).map(function(i,elem){var val=jQuery(this).val();return val==null?null:val.constructor==Array?jQuery.map(val,function(val,i){return{name:elem.name,value:val};}):{name:elem.name,value:val};}).get();}});jQuery.each("ajaxStart,ajaxStop,ajaxComplete,ajaxError,ajaxSuccess,ajaxSend".split(","),function(i,o){jQuery.fn[o]=function(f){return this.bind(o,f);};});var jsc=(new Date).getTime();jQuery.extend({get:function(url,data,callback,type){if(jQuery.isFunction(data)){callback=data;data=null;}return jQuery.ajax({type:"GET",url:url,data:data,success:callback,dataType:type});},getScript:function(url,callback){return jQuery.get(url,null,callback,"script");},getJSON:function(url,data,callback){return jQuery.get(url,data,callback,"json");},post:function(url,data,callback,type){if(jQuery.isFunction(data)){callback=data;data={};}return jQuery.ajax({type:"POST",url:url,data:data,success:callback,dataType:type});},ajaxSetup:function(settings){jQuery.extend(jQuery.ajaxSettings,settings);},ajaxSettings:{global:true,type:"GET",timeout:0,contentType:"application/x-www-form-urlencoded",processData:true,async:true,data:null,username:null,password:null,accepts:{xml:"application/xml, text/xml",html:"text/html",script:"text/javascript, application/javascript",json:"application/json, text/javascript",text:"text/plain",_default:"*/*"}},lastModified:{},ajax:function(s){var jsonp,jsre=/=\?(&|$)/g,status,data;s=jQuery.extend(true,s,jQuery.extend(true,{},jQuery.ajaxSettings,s));if(s.data&&s.processData&&typeof s.data!="string")s.data=jQuery.param(s.data);if(s.dataType=="jsonp"){if(s.type.toLowerCase()=="get"){if(!s.url.match(jsre))s.url+=(s.url.match(/\?/)?"&":"?")+(s.jsonp||"callback")+"=?";}else if(!s.data||!s.data.match(jsre))s.data=(s.data?s.data+"&":"")+(s.jsonp||"callback")+"=?";s.dataType="json";}if(s.dataType=="json"&&(s.data&&s.data.match(jsre)||s.url.match(jsre))){jsonp="jsonp"+jsc++;if(s.data)s.data=(s.data+"").replace(jsre,"="+jsonp+"$1");s.url=s.url.replace(jsre,"="+jsonp+"$1");s.dataType="script";window[jsonp]=function(tmp){data=tmp;success();complete();window[jsonp]=undefined;try{delete window[jsonp];}catch(e){}if(head)head.removeChild(script);};}if(s.dataType=="script"&&s.cache==null)s.cache=false;if(s.cache===false&&s.type.toLowerCase()=="get"){var ts=(new Date()).getTime();var ret=s.url.replace(/(\?|&)_=.*?(&|$)/,"$1_="+ts+"$2");s.url=ret+((ret==s.url)?(s.url.match(/\?/)?"&":"?")+"_="+ts:"");}if(s.data&&s.type.toLowerCase()=="get"){s.url+=(s.url.match(/\?/)?"&":"?")+s.data;s.data=null;}if(s.global&&!jQuery.active++)jQuery.event.trigger("ajaxStart");if((!s.url.indexOf("http")||!s.url.indexOf("//"))&&s.dataType=="script"&&s.type.toLowerCase()=="get"){var head=document.getElementsByTagName("head")[0];var script=document.createElement("script");script.src=s.url;if(s.scriptCharset)script.charset=s.scriptCharset;if(!jsonp){var done=false;script.onload=script.onreadystatechange=function(){if(!done&&(!this.readyState||this.readyState=="loaded"||this.readyState=="complete")){done=true;success();complete();head.removeChild(script);}};}head.appendChild(script);return undefined;}var requestDone=false;var xml=window.ActiveXObject?new ActiveXObject("Microsoft.XMLHTTP"):new XMLHttpRequest();xml.open(s.type,s.url,s.async,s.username,s.password);try{if(s.data)xml.setRequestHeader("Content-Type",s.contentType);if(s.ifModified)xml.setRequestHeader("If-Modified-Since",jQuery.lastModified[s.url]||"Thu, 01 Jan 1970 00:00:00 GMT");xml.setRequestHeader("X-Requested-With","XMLHttpRequest");xml.setRequestHeader("Accept",s.dataType&&s.accepts[s.dataType]?s.accepts[s.dataType]+", */*":s.accepts._default);}catch(e){}if(s.beforeSend)s.beforeSend(xml);if(s.global)jQuery.event.trigger("ajaxSend",[xml,s]);var onreadystatechange=function(isTimeout){if(!requestDone&&xml&&(xml.readyState==4||isTimeout=="timeout")){requestDone=true;if(ival){clearInterval(ival);ival=null;}status=isTimeout=="timeout"&&"timeout"||!jQuery.httpSuccess(xml)&&"error"||s.ifModified&&jQuery.httpNotModified(xml,s.url)&&"notmodified"||"success";if(status=="success"){try{data=jQuery.httpData(xml,s.dataType);}catch(e){status="parsererror";}}if(status=="success"){var modRes;try{modRes=xml.getResponseHeader("Last-Modified");}catch(e){}if(s.ifModified&&modRes)jQuery.lastModified[s.url]=modRes;if(!jsonp)success();}else +jQuery.handleError(s,xml,status);complete();if(s.async)xml=null;}};if(s.async){var ival=setInterval(onreadystatechange,13);if(s.timeout>0)setTimeout(function(){if(xml){xml.abort();if(!requestDone)onreadystatechange("timeout");}},s.timeout);}try{xml.send(s.data);}catch(e){jQuery.handleError(s,xml,null,e);}if(!s.async)onreadystatechange();function success(){if(s.success)s.success(data,status);if(s.global)jQuery.event.trigger("ajaxSuccess",[xml,s]);}function complete(){if(s.complete)s.complete(xml,status);if(s.global)jQuery.event.trigger("ajaxComplete",[xml,s]);if(s.global&&!--jQuery.active)jQuery.event.trigger("ajaxStop");}return xml;},handleError:function(s,xml,status,e){if(s.error)s.error(xml,status,e);if(s.global)jQuery.event.trigger("ajaxError",[xml,s,e]);},active:0,httpSuccess:function(r){try{return!r.status&&location.protocol=="file:"||(r.status>=200&&r.status<300)||r.status==304||r.status==1223||jQuery.browser.safari&&r.status==undefined;}catch(e){}return false;},httpNotModified:function(xml,url){try{var xmlRes=xml.getResponseHeader("Last-Modified");return xml.status==304||xmlRes==jQuery.lastModified[url]||jQuery.browser.safari&&xml.status==undefined;}catch(e){}return false;},httpData:function(r,type){var ct=r.getResponseHeader("content-type");var xml=type=="xml"||!type&&ct&&ct.indexOf("xml")>=0;var data=xml?r.responseXML:r.responseText;if(xml&&data.documentElement.tagName=="parsererror")throw"parsererror";if(type=="script")jQuery.globalEval(data);if(type=="json")data=eval("("+data+")");return data;},param:function(a){var s=[];if(a.constructor==Array||a.jquery)jQuery.each(a,function(){s.push(encodeURIComponent(this.name)+"="+encodeURIComponent(this.value));});else +for(var j in a)if(a[j]&&a[j].constructor==Array)jQuery.each(a[j],function(){s.push(encodeURIComponent(j)+"="+encodeURIComponent(this));});else +s.push(encodeURIComponent(j)+"="+encodeURIComponent(a[j]));return s.join("&").replace(/%20/g,"+");}});jQuery.fn.extend({show:function(speed,callback){return speed?this.animate({height:"show",width:"show",opacity:"show"},speed,callback):this.filter(":hidden").each(function(){this.style.display=this.oldblock||"";if(jQuery.css(this,"display")=="none"){var elem=jQuery("<"+this.tagName+" />").appendTo("body");this.style.display=elem.css("display");if(this.style.display=="none")this.style.display="block";elem.remove();}}).end();},hide:function(speed,callback){return speed?this.animate({height:"hide",width:"hide",opacity:"hide"},speed,callback):this.filter(":visible").each(function(){this.oldblock=this.oldblock||jQuery.css(this,"display");this.style.display="none";}).end();},_toggle:jQuery.fn.toggle,toggle:function(fn,fn2){return jQuery.isFunction(fn)&&jQuery.isFunction(fn2)?this._toggle(fn,fn2):fn?this.animate({height:"toggle",width:"toggle",opacity:"toggle"},fn,fn2):this.each(function(){jQuery(this)[jQuery(this).is(":hidden")?"show":"hide"]();});},slideDown:function(speed,callback){return this.animate({height:"show"},speed,callback);},slideUp:function(speed,callback){return this.animate({height:"hide"},speed,callback);},slideToggle:function(speed,callback){return this.animate({height:"toggle"},speed,callback);},fadeIn:function(speed,callback){return this.animate({opacity:"show"},speed,callback);},fadeOut:function(speed,callback){return this.animate({opacity:"hide"},speed,callback);},fadeTo:function(speed,to,callback){return this.animate({opacity:to},speed,callback);},animate:function(prop,speed,easing,callback){var optall=jQuery.speed(speed,easing,callback);return this[optall.queue===false?"each":"queue"](function(){if(this.nodeType!=1)return false;var opt=jQuery.extend({},optall);var hidden=jQuery(this).is(":hidden"),self=this;for(var p in prop){if(prop[p]=="hide"&&hidden||prop[p]=="show"&&!hidden)return jQuery.isFunction(opt.complete)&&opt.complete.apply(this);if(p=="height"||p=="width"){opt.display=jQuery.css(this,"display");opt.overflow=this.style.overflow;}}if(opt.overflow!=null)this.style.overflow="hidden";opt.curAnim=jQuery.extend({},prop);jQuery.each(prop,function(name,val){var e=new jQuery.fx(self,opt,name);if(/toggle|show|hide/.test(val))e[val=="toggle"?hidden?"show":"hide":val](prop);else{var parts=val.toString().match(/^([+-]=)?([\d+-.]+)(.*)$/),start=e.cur(true)||0;if(parts){var end=parseFloat(parts[2]),unit=parts[3]||"px";if(unit!="px"){self.style[name]=(end||1)+unit;start=((end||1)/e.cur(true))*start;self.style[name]=start+unit;}if(parts[1])end=((parts[1]=="-="?-1:1)*end)+start;e.custom(start,end,unit);}else +e.custom(start,val,"");}});return true;});},queue:function(type,fn){if(jQuery.isFunction(type)||(type&&type.constructor==Array)){fn=type;type="fx";}if(!type||(typeof type=="string"&&!fn))return queue(this[0],type);return this.each(function(){if(fn.constructor==Array)queue(this,type,fn);else{queue(this,type).push(fn);if(queue(this,type).length==1)fn.apply(this);}});},stop:function(clearQueue,gotoEnd){var timers=jQuery.timers;if(clearQueue)this.queue([]);this.each(function(){for(var i=timers.length-1;i>=0;i--)if(timers[i].elem==this){if(gotoEnd)timers[i](true);timers.splice(i,1);}});if(!gotoEnd)this.dequeue();return this;}});var queue=function(elem,type,array){if(!elem)return undefined;type=type||"fx";var q=jQuery.data(elem,type+"queue");if(!q||array)q=jQuery.data(elem,type+"queue",array?jQuery.makeArray(array):[]);return q;};jQuery.fn.dequeue=function(type){type=type||"fx";return this.each(function(){var q=queue(this,type);q.shift();if(q.length)q[0].apply(this);});};jQuery.extend({speed:function(speed,easing,fn){var opt=speed&&speed.constructor==Object?speed:{complete:fn||!fn&&easing||jQuery.isFunction(speed)&&speed,duration:speed,easing:fn&&easing||easing&&easing.constructor!=Function&&easing};opt.duration=(opt.duration&&opt.duration.constructor==Number?opt.duration:{slow:600,fast:200}[opt.duration])||400;opt.old=opt.complete;opt.complete=function(){if(opt.queue!==false)jQuery(this).dequeue();if(jQuery.isFunction(opt.old))opt.old.apply(this);};return opt;},easing:{linear:function(p,n,firstNum,diff){return firstNum+diff*p;},swing:function(p,n,firstNum,diff){return((-Math.cos(p*Math.PI)/2)+0.5)*diff+firstNum;}},timers:[],timerId:null,fx:function(elem,options,prop){this.options=options;this.elem=elem;this.prop=prop;if(!options.orig)options.orig={};}});jQuery.fx.prototype={update:function(){if(this.options.step)this.options.step.apply(this.elem,[this.now,this]);(jQuery.fx.step[this.prop]||jQuery.fx.step._default)(this);if(this.prop=="height"||this.prop=="width")this.elem.style.display="block";},cur:function(force){if(this.elem[this.prop]!=null&&this.elem.style[this.prop]==null)return this.elem[this.prop];var r=parseFloat(jQuery.css(this.elem,this.prop,force));return r&&r>-10000?r:parseFloat(jQuery.curCSS(this.elem,this.prop))||0;},custom:function(from,to,unit){this.startTime=(new Date()).getTime();this.start=from;this.end=to;this.unit=unit||this.unit||"px";this.now=this.start;this.pos=this.state=0;this.update();var self=this;function t(gotoEnd){return self.step(gotoEnd);}t.elem=this.elem;jQuery.timers.push(t);if(jQuery.timerId==null){jQuery.timerId=setInterval(function(){var timers=jQuery.timers;for(var i=0;ithis.options.duration+this.startTime){this.now=this.end;this.pos=this.state=1;this.update();this.options.curAnim[this.prop]=true;var done=true;for(var i in this.options.curAnim)if(this.options.curAnim[i]!==true)done=false;if(done){if(this.options.display!=null){this.elem.style.overflow=this.options.overflow;this.elem.style.display=this.options.display;if(jQuery.css(this.elem,"display")=="none")this.elem.style.display="block";}if(this.options.hide)this.elem.style.display="none";if(this.options.hide||this.options.show)for(var p in this.options.curAnim)jQuery.attr(this.elem.style,p,this.options.orig[p]);}if(done&&jQuery.isFunction(this.options.complete))this.options.complete.apply(this.elem);return false;}else{var n=t-this.startTime;this.state=n/this.options.duration;this.pos=jQuery.easing[this.options.easing||(jQuery.easing.swing?"swing":"linear")](this.state,n,0,1,this.options.duration);this.now=this.start+((this.end-this.start)*this.pos);this.update();}return true;}};jQuery.fx.step={scrollLeft:function(fx){fx.elem.scrollLeft=fx.now;},scrollTop:function(fx){fx.elem.scrollTop=fx.now;},opacity:function(fx){jQuery.attr(fx.elem.style,"opacity",fx.now);},_default:function(fx){fx.elem.style[fx.prop]=fx.now+fx.unit;}};jQuery.fn.offset=function(){var left=0,top=0,elem=this[0],results;if(elem)with(jQuery.browser){var parent=elem.parentNode,offsetChild=elem,offsetParent=elem.offsetParent,doc=elem.ownerDocument,safari2=safari&&parseInt(version)<522&&!/adobeair/i.test(userAgent),fixed=jQuery.css(elem,"position")=="fixed";if(elem.getBoundingClientRect){var box=elem.getBoundingClientRect();add(box.left+Math.max(doc.documentElement.scrollLeft,doc.body.scrollLeft),box.top+Math.max(doc.documentElement.scrollTop,doc.body.scrollTop));add(-doc.documentElement.clientLeft,-doc.documentElement.clientTop);}else{add(elem.offsetLeft,elem.offsetTop);while(offsetParent){add(offsetParent.offsetLeft,offsetParent.offsetTop);if(mozilla&&!/^t(able|d|h)$/i.test(offsetParent.tagName)||safari&&!safari2)border(offsetParent);if(!fixed&&jQuery.css(offsetParent,"position")=="fixed")fixed=true;offsetChild=/^body$/i.test(offsetParent.tagName)?offsetChild:offsetParent;offsetParent=offsetParent.offsetParent;}while(parent&&parent.tagName&&!/^body|html$/i.test(parent.tagName)){if(!/^inline|table.*$/i.test(jQuery.css(parent,"display")))add(-parent.scrollLeft,-parent.scrollTop);if(mozilla&&jQuery.css(parent,"overflow")!="visible")border(parent);parent=parent.parentNode;}if((safari2&&(fixed||jQuery.css(offsetChild,"position")=="absolute"))||(mozilla&&jQuery.css(offsetChild,"position")!="absolute"))add(-doc.body.offsetLeft,-doc.body.offsetTop);if(fixed)add(Math.max(doc.documentElement.scrollLeft,doc.body.scrollLeft),Math.max(doc.documentElement.scrollTop,doc.body.scrollTop));}results={top:top,left:left};}function border(elem){add(jQuery.curCSS(elem,"borderLeftWidth",true),jQuery.curCSS(elem,"borderTopWidth",true));}function add(l,t){left+=parseInt(l)||0;top+=parseInt(t)||0;}return results;};})(); \ No newline at end of file diff --git a/extra/tangle/resources/weave.html b/extra/tangle/resources/weave.html new file mode 100644 index 0000000000..6f9296e31f --- /dev/null +++ b/extra/tangle/resources/weave.html @@ -0,0 +1,18 @@ + + + + + + +
+ + +
+ + +
+
+ + diff --git a/extra/tangle/resources/weave.js b/extra/tangle/resources/weave.js new file mode 100644 index 0000000000..2b36982451 --- /dev/null +++ b/extra/tangle/resources/weave.js @@ -0,0 +1,27 @@ +$(function() { $.getJSON("/all", false, function(json) { + var nodes = $('#nodes'); + for (node in json) { + nodes.append(""); + } + nodes.change(function(){ + if (this.value == 'new') { + $('#node-content').hide(); + $('#edit-wrapper').show(); + } else { + $('#node-content').show(); + $('#edit-wrapper').hide(); + $.get('/node', { node_id: this.value }, function(data){ + $('#node-content').text(data); + }); + } + }); + $('#node-submit').click(function(){ + $.post('/node', { node_content: $('#node-content-edit').val() }, function(data){ + nodes.append(""); + var option = nodes.get(0).options[data]; + option.selected = true; + nodes.change(); + }); + return false; + }); +});}) diff --git a/extra/tangle/sandbox/sandbox.factor b/extra/tangle/sandbox/sandbox.factor new file mode 100644 index 0000000000..b6e110ada5 --- /dev/null +++ b/extra/tangle/sandbox/sandbox.factor @@ -0,0 +1,18 @@ +USING: continuations db db.sqlite http.server io.files kernel namespaces semantic-db tangle tangle.path ; +IN: tangle.sandbox + +: db-path "tangle-sandbox.db" temp-file ; +: sandbox-db db-path sqlite-db ; +: delete-db [ db-path delete-file ] ignore-errors ; + +: make-sandbox ( tangle -- ) + [ + init-semantic-db + ensure-root "foo" create-file "First Page" create-node swap has-filename + ] with-tangle ; + +: new-sandbox ( -- ) + development-mode on + delete-db sandbox-db f + [ make-sandbox ] [ ] bi + main-responder set ; diff --git a/extra/tangle/summary.txt b/extra/tangle/summary.txt new file mode 100644 index 0000000000..26f0a3e9af --- /dev/null +++ b/extra/tangle/summary.txt @@ -0,0 +1 @@ +A web framework using semantic-db as a backend diff --git a/extra/tangle/tangle-tests.factor b/extra/tangle/tangle-tests.factor index 7b78e07473..c7e9f2d79a 100644 --- a/extra/tangle/tangle-tests.factor +++ b/extra/tangle/tangle-tests.factor @@ -12,9 +12,9 @@ IN: tangle.tests 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 + [ "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 >array ] 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 diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index 9dad155777..afaf3da3cd 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions io kernel math.parser namespaces semantic-db sequences strings ; +USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ; IN: tangle GENERIC: render* ( content templater -- output ) @@ -19,15 +19,57 @@ C: tangle : with-tangle ( tangle quot -- ) [ [ db>> ] [ seq>> ] bi ] dip with-db ; -TUPLE: node-responder tangle ; -C: node-responder +: ( text -- response ) + "text/plain" swap >>body ; -: node-response ( responder id -- responder ) - load-node [ node-content ] [ "Unknown node" ] if* >>body ; +: node-response ( id -- response ) + load-node [ node-content ] [ <404> ] if* ; -M: node-responder call-responder* ( path responder -- response ) +: display-node ( params -- response ) + [ + "node_id" swap at* [ + string>number node-response + ] [ + drop <400> + ] if + ] [ + <400> + ] if* ; + +: submit-node ( params -- response ) + [ + "node_content" swap at* [ + create-node id>> number>string + ] [ + drop <400> + ] if + ] [ + <400> + ] if* ; + +: ( -- responder ) + [ params get display-node ] >>display + [ params get submit-node ] >>submit ; + +TUPLE: path-responder ; +C: path-responder + +M: path-responder call-responder* ( path responder -- response ) + drop path>file [ node-content ] [ <404> ] if* ; + +: ( obj -- response ) + "application/json" swap >json >>body ; + +TUPLE: tangle-dispatcher < dispatcher tangle ; + +: ( tangle -- dispatcher ) + tangle-dispatcher new-dispatcher swap >>tangle + >>default + "extra/tangle/resources" resource-path "resources" add-responder + "node" add-responder + [ all-node-ids ] >>display "all" add-responder ; + +M: tangle-dispatcher call-responder* ( path dispatcher -- response ) dup tangle>> [ - "text/plain" nip request get request-params - [ "node-id" swap at* [ string>number node-response ] [ drop ] if ] when* nip + find-responder call-responder ] with-tangle ; -