Merge branch 'master' of git://factorcode.org/git/wrunt
Slava Pestov
commit
fc5d0b2330
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -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 <date> 6101.94 open-account my-account set
|
||||
[ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
|
||||
[ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
|
||||
] with-scope
|
||||
|
||||
[
|
||||
"Petty Cash" 0.07 1 2006 12 1 <date> 10962.18 open-account my-account set
|
||||
[ 11027 ] [ my-account get 2007 1 2 <date> process-to-date balance>> round >integer ] unit-test
|
||||
] with-scope
|
||||
|
||||
[
|
||||
"Saving to buy a pony" 0.0725 1 2008 3 3 <date> 11106.24 open-account my-account set
|
||||
[ 8416 ] [
|
||||
my-account get [
|
||||
2008 3 11 <date> -750 "Need to buy food" <transaction> ,
|
||||
2008 3 25 <date> -500 "Going to a party" <transaction> ,
|
||||
2008 4 8 <date> -800 "Losing interest in the pony..." <transaction> ,
|
||||
2008 4 8 <date> -700 "Buying a rocking horse" <transaction> ,
|
||||
] { } make inserting-transactions balance>> round >integer
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
||||
[
|
||||
[ 6781 ] [
|
||||
"..." 0.07 1 2007 4 10 <date> 4398.50 open-account
|
||||
2007 10 26 <date> 2000 "..." <transaction> 1array inserting-transactions
|
||||
2008 4 10 <date> process-to-date dup balance>> swap unpaid-interest>> + round >integer
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
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 ;
|
||||
|
||||
: <account> ( name interest-rate interest-payment-day opening-date -- account )
|
||||
V{ } clone 0 pick account boa ;
|
||||
|
||||
TUPLE: transaction date amount description ;
|
||||
C: <transaction> transaction
|
||||
|
||||
: >>transaction ( account transaction -- account )
|
||||
over transactions>> push ;
|
||||
|
||||
: total ( transactions -- balance )
|
||||
0 [ amount>> + ] reduce ;
|
||||
|
||||
: balance>> ( account -- balance ) transactions>> total ;
|
||||
|
||||
: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
|
||||
>r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
|
||||
|
||||
: daily-rate ( yearly-rate day -- daily-rate )
|
||||
days-in-year / ;
|
||||
|
||||
: daily-rate>> ( account date -- rate )
|
||||
[ interest-rate>> ] dip daily-rate ;
|
||||
|
||||
: before? ( date date -- ? ) <=> 0 < ;
|
||||
|
||||
: transactions-on-date ( account date -- transactions )
|
||||
[ before? ] curry filter ;
|
||||
|
||||
: balance-on-date ( account date -- balance )
|
||||
transactions-on-date total ;
|
||||
|
||||
: pay-interest ( account date -- )
|
||||
over unpaid-interest>> "Interest Credit" <transaction>
|
||||
>>transaction 0 >>unpaid-interest drop ;
|
||||
|
||||
: interest-payment-day? ( account date -- ? )
|
||||
day>> swap interest-payment-day>> = ;
|
||||
|
||||
: ?pay-interest ( account date -- )
|
||||
2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
|
||||
|
||||
: unpaid-interest+ ( account amount -- account )
|
||||
over unpaid-interest>> + >>unpaid-interest ;
|
||||
|
||||
: accumulate-interest ( account date -- )
|
||||
[ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
|
||||
>>interest-last-paid drop ;
|
||||
|
||||
: process-day ( account date -- )
|
||||
2dup accumulate-interest ?pay-interest ;
|
||||
|
||||
: each-day ( quot start end -- )
|
||||
2dup before? [
|
||||
>r dup >r over >r swap call r> r> 1 days time+ r> each-day
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
|
||||
: process-to-date ( account date -- account )
|
||||
over interest-last-paid>> 1 days time+
|
||||
[ dupd process-day ] spin each-day ;
|
||||
|
||||
: inserting-transactions ( account transactions -- account )
|
||||
[ [ date>> process-to-date ] keep >>transaction ] each ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Bank account simulator for compound interest calculated daily and paid monthly
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -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" } ;
|
||||
|
|
|
|||
|
|
@ -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!" play-as-morse ] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -85,25 +86,25 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: dot ( -- ch ) CHAR: . ;
|
||||
: dash ( -- ch ) CHAR: - ;
|
||||
: char-gap ( -- ch ) CHAR: \s ;
|
||||
: word-gap ( -- ch ) CHAR: / ;
|
||||
: dot-char ( -- ch ) CHAR: . ;
|
||||
: dash-char ( -- ch ) CHAR: - ;
|
||||
: char-gap-char ( -- ch ) CHAR: \s ;
|
||||
: word-gap-char ( -- ch ) CHAR: / ;
|
||||
|
||||
: =parser ( obj -- parser )
|
||||
[ = ] curry satisfy ;
|
||||
|
||||
LAZY: 'dot' ( -- parser )
|
||||
dot =parser ;
|
||||
dot-char =parser ;
|
||||
|
||||
LAZY: 'dash' ( -- parser )
|
||||
dash =parser ;
|
||||
dash-char =parser ;
|
||||
|
||||
LAZY: 'char-gap' ( -- parser )
|
||||
char-gap =parser ;
|
||||
char-gap-char =parser ;
|
||||
|
||||
LAZY: 'word-gap' ( -- parser )
|
||||
word-gap =parser ;
|
||||
word-gap-char =parser ;
|
||||
|
||||
LAZY: 'morse-char' ( -- parser )
|
||||
'dot' 'dash' <|> <+> ;
|
||||
|
|
@ -123,3 +124,53 @@ PRIVATE>
|
|||
] map >string
|
||||
] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
|
||||
|
||||
<PRIVATE
|
||||
SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
|
||||
|
||||
: queue ( symbol -- )
|
||||
get source get swap queue-buffer ;
|
||||
|
||||
: dot ( -- ) dot-buffer queue ;
|
||||
: dash ( -- ) dash-buffer queue ;
|
||||
: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
|
||||
: letter-gap ( -- ) letter-gap-buffer queue ;
|
||||
|
||||
: sine-buffer ( seconds -- id )
|
||||
>r 8 22000 880 r> <sine-wave-buffer> send-buffer* ;
|
||||
|
||||
: silent-buffer ( seconds -- id )
|
||||
8 22000 rot <silent-buffer> 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 ;
|
||||
|
||||
: play-as-morse ( str -- )
|
||||
0.05 play-as-morse* ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
: <buffer> ( 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) ;
|
||||
|
||||
: <sine-wave-buffer> ( bits sample-freq freq seconds -- buffer )
|
||||
>r dupd r> sine-wave-seq <buffer> ;
|
||||
|
||||
: <silent-buffer> ( bits sample-freq seconds -- buffer )
|
||||
dupd * >integer [ drop 0 ] map <buffer> ;
|
||||
|
||||
: play-sine-wave ( bits sample-freq freq seconds -- )
|
||||
init-openal
|
||||
<sine-wave-buffer> send-buffer*
|
||||
1 gen-sources first
|
||||
[ AL_BUFFER rot set-source-param ] [ source-play ] bi
|
||||
check-error ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -1,16 +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 ;
|
||||
|
||||
: context ( -- context-id )
|
||||
\ context get ;
|
||||
|
||||
: set-context ( context-id -- )
|
||||
\ context set ;
|
||||
|
||||
: with-context ( context-id quot -- )
|
||||
>r \ context r> with-variable ;
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors db.tuples hashtables kernel sets
|
||||
semantic-db semantic-db.relations sequences sequences.deep ;
|
||||
IN: semantic-db.hierarchy
|
||||
|
||||
TUPLE: tree id children ;
|
||||
C: <tree> tree
|
||||
|
||||
: has-parent-relation ( -- relation-id )
|
||||
"has parent" relation-id ;
|
||||
|
||||
: parent-child* ( parent child -- arc-id )
|
||||
has-parent-relation spin create-arc* ;
|
||||
|
||||
: parent-child ( parent child -- )
|
||||
parent-child* drop ;
|
||||
|
||||
: un-parent-child ( parent child -- )
|
||||
has-parent-relation spin <arc> select-tuples [ id>> delete-arc ] each ;
|
||||
|
||||
: child-arcs ( node-id -- child-arcs )
|
||||
has-parent-relation f rot <arc> select-tuples ;
|
||||
|
||||
: children ( node-id -- children )
|
||||
child-arcs [ subject>> ] map ;
|
||||
|
||||
: parent-arcs ( node-id -- parent-arcs )
|
||||
has-parent-relation swap f <arc> select-tuples ;
|
||||
|
||||
: parents ( node-id -- parents )
|
||||
parent-arcs [ object>> ] map ;
|
||||
|
||||
: get-node-hierarchy ( node-id -- tree )
|
||||
dup children [ get-node-hierarchy ] map <tree> ;
|
||||
|
||||
: (get-root-nodes) ( node-id -- root-nodes/node-id )
|
||||
dup parents dup empty? [
|
||||
drop
|
||||
] [
|
||||
nip [ (get-root-nodes) ] map
|
||||
] if ;
|
||||
|
||||
: get-root-nodes ( node-id -- root-nodes )
|
||||
(get-root-nodes) flatten prune ;
|
||||
|
|
@ -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 swap [ get-relation ] [ create-relation* ] ensure2 ;
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
USING: accessors arrays continuations db db.sqlite
|
||||
db.tuples io.files kernel math namespaces semantic-db
|
||||
semantic-db.context semantic-db.hierarchy
|
||||
semantic-db.relations sequences sorting tools.test
|
||||
USING: accessors arrays continuations db db.sqlite db.tuples io.files
|
||||
kernel math namespaces semantic-db sequences sorting tools.test
|
||||
tools.walker ;
|
||||
IN: semantic-db.tests
|
||||
|
||||
SYMBOL: context
|
||||
|
||||
: db-path "semantic-db-test.db" temp-file ;
|
||||
: test-db db-path sqlite-db ;
|
||||
: delete-db [ db-path delete-file ] ignore-errors ;
|
||||
|
|
@ -12,61 +12,56 @@ IN: semantic-db.tests
|
|||
delete-db
|
||||
|
||||
test-db [
|
||||
create-node-table create-arc-table
|
||||
[ 1 ] [ "first node" create-node* ] unit-test
|
||||
[ 2 ] [ "second node" create-node* ] unit-test
|
||||
[ 3 ] [ "third node" create-node* ] unit-test
|
||||
[ 4 ] [ f create-node* ] unit-test
|
||||
[ 5 ] [ 1 2 3 create-arc* ] unit-test
|
||||
] with-db
|
||||
node create-table arc create-table
|
||||
[ 1 ] [ "first node" create-node id>> ] unit-test
|
||||
[ 2 ] [ "second node" create-node id>> ] unit-test
|
||||
[ 3 ] [ "third node" create-node id>> ] unit-test
|
||||
[ 4 ] [ f create-node id>> ] unit-test
|
||||
[ ] [ 1 f <node> 2 f <node> 3 f <node> create-arc ] unit-test
|
||||
[ { 1 2 3 4 } ] [ all-node-ids ] unit-test
|
||||
] with-db delete-db
|
||||
|
||||
delete-db
|
||||
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"test content" create-context* [
|
||||
[ 4 ] [ context ] unit-test
|
||||
[ 5 ] [ context "is test content" create-relation* ] unit-test
|
||||
[ 5 ] [ context "is test content" get-relation ] unit-test
|
||||
[ 5 ] [ "is test content" relation-id ] unit-test
|
||||
[ 7 ] [ "has parent" relation-id ] unit-test
|
||||
[ 7 ] [ "has parent" relation-id ] unit-test
|
||||
[ "has parent" ] [ "has parent" relation-id node-content ] unit-test
|
||||
[ "test content" ] [ context node-content ] unit-test
|
||||
] with-context
|
||||
! type-type 1array [ "type" ensure-type ] unit-test
|
||||
! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
|
||||
! [ 1 ] [ type-type select-node-of-type ] unit-test
|
||||
! [ t ] [ "content" ensure-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test
|
||||
! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test
|
||||
] with-db
|
||||
|
||||
delete-db
|
||||
|
||||
! test hierarchy
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"family tree" create-context* [
|
||||
"adam" create-node* "adam" set
|
||||
"eve" create-node* "eve" set
|
||||
"bob" create-node* "bob" set
|
||||
"fran" create-node* "fran" set
|
||||
"charlie" create-node* "charlie" set
|
||||
"gertrude" create-node* "gertrude" set
|
||||
[ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
|
||||
{ { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] bi@ parent-child ] each
|
||||
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
|
||||
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map natural-sort >array ] unit-test
|
||||
[ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
|
||||
] with-context
|
||||
] with-db
|
||||
|
||||
delete-db
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"test content" create-context context set
|
||||
[ T{ node f 3 "test content" } ] [ context get ] unit-test
|
||||
[ T{ node f 4 "is test content" } ] [ "is test content" context get create-relation ] unit-test
|
||||
[ T{ node f 4 "is test content" } ] [ "is test content" context get get-relation ] unit-test
|
||||
[ T{ node f 4 "is test content" } ] [ "is test content" context get ensure-relation ] unit-test
|
||||
[ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
|
||||
[ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
|
||||
[ "has parent" ] [ "has parent" context get ensure-relation node-content ] unit-test
|
||||
[ "test content" ] [ context get node-content ] unit-test
|
||||
] with-db delete-db
|
||||
|
||||
! "test1" "test1-relation-id-word" f f f f <relation-definition> define-relation
|
||||
! "test2" t t t t t <relation-definition> define-relation
|
||||
RELATION: test3
|
||||
test-db [
|
||||
init-semantic-db
|
||||
! [ T{ node f 3 "test1" } ] [ test1-relation-id-word ] unit-test
|
||||
! [ T{ node f 4 "test2" } ] [ test2-relation ] unit-test
|
||||
[ T{ node f 4 "test3" } ] [ test3-relation ] unit-test
|
||||
] with-db delete-db
|
||||
|
||||
! test hierarchy
|
||||
RELATION: has-parent
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"adam" create-node "adam" set
|
||||
"eve" create-node "eve" set
|
||||
"bob" create-node "bob" set
|
||||
"fran" create-node "fran" set
|
||||
"charlie" create-node "charlie" set
|
||||
"gertrude" create-node "gertrude" set
|
||||
[ ] [ "bob" get "adam" get has-parent ] unit-test
|
||||
{ { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] bi@ has-parent ] each
|
||||
[ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "bob" get has-parent-relation parents [ node-content ] map ] unit-test
|
||||
[ "fran" { "charlie" } ] [ "fran" get has-parent-relation get-node-tree-s dup node>> node-content swap children>> [ node>> node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "charlie" get has-parent-relation get-root-nodes [ node-content ] map natural-sort >array ] unit-test
|
||||
[ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation parents [ node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ has-parent-relation ultimate-objects node-results [ node-content ] map ] unit-test
|
||||
[ { "fran" "gertrude" } ] [ has-parent-relation ultimate-subjects node-results [ node-content ] map ] unit-test
|
||||
] with-db delete-db
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,13 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ;
|
||||
USING: accessors arrays combinators combinators.cleave combinators.lib
|
||||
continuations db db.tuples db.types db.sqlite kernel math
|
||||
math.parser namespaces parser sets sequences sequences.deep
|
||||
sequences.lib strings words ;
|
||||
IN: semantic-db
|
||||
|
||||
TUPLE: node id content ;
|
||||
: <node> ( content -- node )
|
||||
node new swap >>content ;
|
||||
|
||||
: <id-node> ( id -- node )
|
||||
node new swap >>id ;
|
||||
C: <node> node
|
||||
|
||||
node "node"
|
||||
{
|
||||
|
|
@ -16,74 +15,271 @@ node "node"
|
|||
{ "content" "content" TEXT }
|
||||
} define-persistent
|
||||
|
||||
: create-node-table ( -- )
|
||||
node create-table ;
|
||||
: delete-node ( node -- ) delete-tuples ;
|
||||
: create-node ( content -- node ) f swap <node> dup insert-tuple ;
|
||||
: load-node ( id -- node ) f <node> select-tuple ;
|
||||
|
||||
: delete-node ( node-id -- )
|
||||
<id-node> delete-tuples ;
|
||||
: node-content ( node -- content )
|
||||
dup content>> [ nip ] [ select-tuple content>> ] if* ;
|
||||
|
||||
: create-node* ( str -- node-id )
|
||||
<node> dup insert-tuple id>> ;
|
||||
: node= ( node node -- ? ) [ id>> ] bi@ = ;
|
||||
|
||||
: create-node ( str -- )
|
||||
create-node* drop ;
|
||||
! TODO: get rid of arc id and write our own sql
|
||||
TUPLE: arc id subject object relation ;
|
||||
|
||||
: node-content ( id -- str )
|
||||
f <node> swap >>id select-tuple content>> ;
|
||||
|
||||
TUPLE: arc id relation subject object ;
|
||||
|
||||
: <arc> ( relation subject object -- arc )
|
||||
arc new swap >>object swap >>subject swap >>relation ;
|
||||
: <arc> ( subject object relation -- arc )
|
||||
arc new swap >>relation swap >>object swap >>subject ;
|
||||
|
||||
: <id-arc> ( id -- arc )
|
||||
arc new swap >>id ;
|
||||
|
||||
: insert-arc ( arc -- )
|
||||
f <node> dup insert-tuple id>> >>id insert-tuple ;
|
||||
: delete-arc ( arc -- ) delete-tuples ;
|
||||
|
||||
: delete-arc ( arc-id -- )
|
||||
dup delete-node <id-arc> delete-tuples ;
|
||||
: create-arc ( subject object relation -- )
|
||||
[ id>> ] 3apply <arc> insert-tuple ;
|
||||
|
||||
: create-arc* ( relation subject object -- arc-id )
|
||||
<arc> dup insert-arc id>> ;
|
||||
: nodes>arc ( subject object relation -- arc )
|
||||
[ [ id>> ] [ f ] if* ] 3apply <arc> ;
|
||||
|
||||
: create-arc ( relation subject object -- )
|
||||
create-arc* drop ;
|
||||
: select-arcs ( subject object relation -- arcs )
|
||||
nodes>arc select-tuples ;
|
||||
|
||||
: has-arc? ( subject object relation -- ? )
|
||||
select-arcs length 0 > ;
|
||||
|
||||
: select-arc-subjects ( subject object relation -- subjects )
|
||||
select-arcs [ subject>> f <node> ] map ;
|
||||
|
||||
: select-arc-subject ( subject object relation -- subject )
|
||||
select-arcs ?first [ subject>> f <node> ] [ f ] if* ;
|
||||
|
||||
: select-subjects ( object relation -- subjects )
|
||||
f -rot select-arc-subjects ;
|
||||
|
||||
: select-subject ( object relation -- subject )
|
||||
f -rot select-arc-subject ;
|
||||
|
||||
: select-arc-objects ( subject object relation -- objects )
|
||||
select-arcs [ object>> f <node> ] map ;
|
||||
|
||||
: select-arc-object ( subject object relation -- object )
|
||||
select-arcs ?first [ object>> f <node> ] [ f ] if* ;
|
||||
|
||||
: select-objects ( subject relation -- objects )
|
||||
f swap select-arc-objects ;
|
||||
|
||||
: select-object ( subject relation -- object )
|
||||
f swap select-arc-object ;
|
||||
|
||||
: delete-arcs ( subject object relation -- )
|
||||
select-arcs [ delete-arc ] each ;
|
||||
|
||||
arc "arc"
|
||||
{
|
||||
{ "id" "id" INTEGER +user-assigned-id+ } ! foreign key to node table?
|
||||
{ "id" "id" +db-assigned-id+ +autoincrement+ }
|
||||
{ "relation" "relation" INTEGER +not-null+ }
|
||||
{ "subject" "subject" INTEGER +not-null+ }
|
||||
{ "object" "object" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: create-arc-table ( -- )
|
||||
arc create-table ;
|
||||
|
||||
: create-bootstrap-nodes ( -- )
|
||||
"semantic-db" create-node
|
||||
"has context" create-node ;
|
||||
"semantic-db" create-node drop
|
||||
"has-context" create-node drop ;
|
||||
|
||||
: semantic-db-context 1 ;
|
||||
: has-context-relation 2 ;
|
||||
: semantic-db-context T{ node f 1 "semantic-db" } ;
|
||||
: has-context-relation T{ node f 2 "has-context" } ;
|
||||
|
||||
: create-bootstrap-arcs ( -- )
|
||||
has-context-relation has-context-relation semantic-db-context create-arc ;
|
||||
has-context-relation semantic-db-context has-context-relation create-arc ;
|
||||
|
||||
: init-semantic-db ( -- )
|
||||
create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
|
||||
node create-table arc create-table
|
||||
create-bootstrap-nodes create-bootstrap-arcs ;
|
||||
|
||||
! db utilities
|
||||
: results ( bindings sql -- array )
|
||||
f f <simple-statement> [ do-bound-query ] with-disposal ;
|
||||
|
||||
: node-result ( result -- node )
|
||||
dup first string>number swap second <node> ;
|
||||
|
||||
: ?1node-result ( results -- node )
|
||||
?first [ node-result ] [ f ] if* ;
|
||||
|
||||
: node-results ( results -- nodes )
|
||||
[ node-result ] map ;
|
||||
|
||||
: param ( value key type -- param )
|
||||
swapd <sqlite-low-level-binding> ;
|
||||
|
||||
: single-int-results ( bindings sql -- array )
|
||||
f f <simple-statement> [ do-bound-query ] with-disposal
|
||||
[ first string>number ] map ;
|
||||
: all-node-ids ( -- seq )
|
||||
f "select n.id from node n" results [ first string>number ] map ;
|
||||
|
||||
: ensure2 ( x y quot1 quot2 -- z )
|
||||
#! quot1 ( x y -- z/f ) finds an existing z
|
||||
#! quot2 ( x y -- z ) creates a new z if quot1 returns f
|
||||
>r >r 2dup r> call [ 2nip ] r> if* ;
|
||||
: subjects-with-cor ( content object relation -- sql-results )
|
||||
[ id>> ] bi@
|
||||
[
|
||||
":relation" INTEGER param ,
|
||||
":object" INTEGER param ,
|
||||
":content" TEXT param ,
|
||||
] { } make
|
||||
"select n.id, n.content from node n, arc a where n.content = :content and n.id = a.subject and a.relation = :relation and a.object = :object" results ;
|
||||
|
||||
: objects-with-csr ( content subject relation -- sql-results )
|
||||
[ id>> ] bi@
|
||||
[
|
||||
":relation" INTEGER param ,
|
||||
":subject" INTEGER param ,
|
||||
":content" TEXT param ,
|
||||
] { } make
|
||||
"select n.id, n.content from node n, arc a where n.content = :content and n.id = a.object and a.relation = :relation and a.subject = :subject" results ;
|
||||
|
||||
: (with-relation) ( content relation -- bindings sql )
|
||||
id>> [ ":relation" INTEGER param , ":content" TEXT param , ] { } make
|
||||
"select distinct n.id, n.content from node n, arc a where n.content = :content and a.relation = :relation" ;
|
||||
|
||||
: subjects-with-relation ( content relation -- sql-results )
|
||||
(with-relation) " and a.object = n.id" append results ;
|
||||
|
||||
: objects-with-relation ( content relation -- sql-results )
|
||||
(with-relation) " and a.subject = n.id" append results ;
|
||||
|
||||
: (ultimate) ( relation b a -- sql-results )
|
||||
[
|
||||
"select distinct n.id, n.content from node n, arc a where a.relation = :relation and n.id = a." % % " and n.id not in (select b." % % " from arc b where b.relation = :relation)" %
|
||||
] "" make [ id>> ":relation" INTEGER param 1array ] dip results ;
|
||||
|
||||
: ultimate-objects ( relation -- sql-results )
|
||||
"subject" "object" (ultimate) ;
|
||||
|
||||
: ultimate-subjects ( relation -- sql-results )
|
||||
"object" "subject" (ultimate) ;
|
||||
|
||||
! contexts:
|
||||
! - a node n is a context iff there exists a relation r such that r has context n
|
||||
: create-context ( context-name -- context ) create-node ;
|
||||
|
||||
: get-context ( context-name -- context/f )
|
||||
has-context-relation subjects-with-relation ?1node-result ;
|
||||
|
||||
: ensure-context ( context-name -- context )
|
||||
dup get-context [
|
||||
nip
|
||||
] [
|
||||
create-context
|
||||
] if* ;
|
||||
|
||||
! relations:
|
||||
! - have a context in context 'semantic-db'
|
||||
|
||||
: create-relation ( relation-name context -- relation )
|
||||
[ create-node dup ] dip has-context-relation create-arc ;
|
||||
|
||||
: get-relation ( relation-name context -- relation/f )
|
||||
has-context-relation subjects-with-cor ?1node-result ;
|
||||
|
||||
: ensure-relation ( relation-name context -- relation )
|
||||
2dup get-relation [
|
||||
2nip
|
||||
] [
|
||||
create-relation
|
||||
] if* ;
|
||||
|
||||
TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
|
||||
C: <relation-definition> relation-definition
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: default-word-name ( relate-word-name word-type -- word-name )
|
||||
{
|
||||
{ "relate" [ ] }
|
||||
{ "id-word" [ "-relation" append ] }
|
||||
{ "unrelate" [ "!" swap append ] }
|
||||
{ "related?" [ "?" append ] }
|
||||
{ "subjects" [ "-subjects" append ] }
|
||||
{ "objects" [ "-objects" append ] }
|
||||
} case ;
|
||||
|
||||
: choose-word-name ( relation-definition given-word-name word-type -- word-name )
|
||||
over string? [
|
||||
drop nip
|
||||
] [
|
||||
nip [ relate>> ] dip default-word-name
|
||||
] if ;
|
||||
|
||||
: (define-relation-word) ( id-word word-name definition -- id-word )
|
||||
>r create-in over [ execute ] curry r> compose define ;
|
||||
|
||||
: define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word )
|
||||
>r >r [
|
||||
pick swap r> choose-word-name r> (define-relation-word)
|
||||
] [
|
||||
r> r> 2drop
|
||||
] if* ;
|
||||
|
||||
: define-relation-words ( relation-definition id-word -- )
|
||||
over relate>> "relate" [ create-arc ] define-relation-word
|
||||
over unrelate>> "unrelate" [ delete-arcs ] define-relation-word
|
||||
over related?>> "related?" [ has-arc? ] define-relation-word
|
||||
over subjects>> "subjects" [ select-subjects ] define-relation-word
|
||||
over objects>> "objects" [ select-objects ] define-relation-word
|
||||
2drop ;
|
||||
|
||||
: define-id-word ( relation-definition id-word -- )
|
||||
[ relate>> ] dip tuck word-vocabulary
|
||||
[ ensure-context ensure-relation ] 2curry define ;
|
||||
|
||||
: create-id-word ( relation-definition -- id-word )
|
||||
dup id-word>> "id-word" choose-word-name create-in ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-relation ( relation-definition -- )
|
||||
dup create-id-word 2dup define-id-word define-relation-words ;
|
||||
|
||||
: RELATION:
|
||||
scan t t t t t <relation-definition> define-relation ; parsing
|
||||
|
||||
! hierarchy
|
||||
TUPLE: node-tree node children ;
|
||||
C: <node-tree> node-tree
|
||||
|
||||
: children ( node has-parent-relation -- children ) select-subjects ;
|
||||
: parents ( node has-parent-relation -- parents ) select-objects ;
|
||||
|
||||
: get-node-tree ( node child-selector -- node-tree )
|
||||
2dup call >r [ get-node-tree ] curry r> swap map <node-tree> ;
|
||||
|
||||
! : get-node-tree ( node has-parent-relation -- node-tree )
|
||||
! 2dup children >r [ get-node-tree ] curry r> swap map <node-tree> ;
|
||||
: get-node-tree-s ( node has-parent-relation -- tree )
|
||||
[ select-subjects ] curry get-node-tree ;
|
||||
|
||||
: get-node-tree-o ( node has-child-relation -- tree )
|
||||
[ select-objects ] curry get-node-tree ;
|
||||
|
||||
: (get-node-chain) ( node next-selector seq -- seq )
|
||||
pick [
|
||||
over push >r [ call ] keep r> (get-node-chain)
|
||||
] [
|
||||
2nip
|
||||
] if* ;
|
||||
|
||||
: get-node-chain ( node next-selector -- seq )
|
||||
V{ } clone (get-node-chain) ;
|
||||
|
||||
: get-node-chain-o ( node relation -- seq )
|
||||
[ select-object ] curry get-node-chain ;
|
||||
|
||||
: get-node-chain-s ( node relation -- seq )
|
||||
[ select-subject ] curry get-node-chain ;
|
||||
|
||||
: (get-root-nodes) ( node has-parent-relation -- root-nodes/node )
|
||||
2dup parents dup empty? [
|
||||
2drop
|
||||
] [
|
||||
>r nip [ (get-root-nodes) ] curry r> swap map
|
||||
] if ;
|
||||
|
||||
: get-root-nodes ( node has-parent-relation -- root-nodes )
|
||||
(get-root-nodes) flatten prune ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
USING: html kernel semantic-db tangle.html tools.test ;
|
||||
IN: tangle.html.tests
|
||||
|
||||
[ "test" ] [ "test" >html ] unit-test
|
||||
[ "<ul><li>An Item</li></ul>" ] [ { "An Item" } <ulist> >html ] unit-test
|
||||
[ "<ul><li>One</li><li>Two</li><li>Three, ah ah ah</li></ul>" ] [ { "One" "Two" "Three, ah ah ah" } <ulist> >html ] unit-test
|
||||
[ "<a href='foo/bar'>some link</a>" ] [ "foo/bar" "some link" <link> >html ] unit-test
|
||||
|
|
@ -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 ;
|
||||
: <ulist> ( items -- element )
|
||||
H{ } clone swap ulist boa ;
|
||||
|
||||
TUPLE: link < element href text ;
|
||||
: <link> ( href text -- element )
|
||||
H{ } clone -rot link boa ;
|
||||
|
||||
GENERIC: >html ( element -- str )
|
||||
|
||||
M: string >html ( str -- str ) ;
|
||||
|
||||
M: link >html ( link -- str )
|
||||
[ <a dup href>> =href a> text>> write </a> ] with-string-writer ;
|
||||
|
||||
M: node >html ( node -- str )
|
||||
dup node>path [
|
||||
swap node-content <link> >html
|
||||
] [
|
||||
node-content
|
||||
] if* ;
|
||||
|
||||
M: ulist >html ( ulist -- str )
|
||||
[
|
||||
<ul> items>> [ <li> >html write </li> ] each </ul>
|
||||
] with-string-writer ;
|
||||
|
|
@ -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>> <ulist> ;
|
||||
: menu>html ( menu -- str ) menu>ulist >html ;
|
||||
|
|
@ -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> page
|
||||
|
||||
: load-page-content ( node -- content )
|
||||
has-content-objects [ node-content ] map concat ;
|
||||
|
||||
: load-page ( node -- page )
|
||||
dup [ has-abbreviation-objects ?first ] keep
|
||||
[ authored-by-objects ?first ] keep
|
||||
[ authored-on-objects ?first ] keep
|
||||
load-page-content <page> ;
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
! 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* ;
|
||||
|
||||
: path>node ( path -- node )
|
||||
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= [
|
||||
drop nip
|
||||
] [
|
||||
dup node-content pick push
|
||||
parent-directory [
|
||||
(node>path)
|
||||
] [
|
||||
2drop f
|
||||
] if*
|
||||
] if ;
|
||||
|
||||
: node>path* ( root node -- path )
|
||||
V{ } clone swap (node>path) dup empty?
|
||||
[ drop f ] [ <reversed> ] if ;
|
||||
|
||||
: node>path ( node -- path )
|
||||
ensure-root swap node>path* ;
|
||||
|
||||
: file>path ( node -- path )
|
||||
has-filename-objects ?first [ node>path ] [ f ] if* ;
|
||||
File diff suppressed because one or more lines are too long
|
|
@ -0,0 +1,18 @@
|
|||
<html>
|
||||
<head>
|
||||
<script type="text/javascript" src="jquery-1.2.3.min.js"></script>
|
||||
<script type="text/javascript" src="weave.js"></script>
|
||||
</head>
|
||||
<body>
|
||||
<form id="node-form">
|
||||
<select id="nodes">
|
||||
<option value="new">New</option>
|
||||
</select>
|
||||
<div id="node-content" style="display: none;"></div>
|
||||
<div id="edit-wrapper">
|
||||
<textarea id="node-content-edit"></textarea>
|
||||
<button id='node-submit'>Save Node</button>
|
||||
</div>
|
||||
</form>
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
$(function() { $.getJSON("/all", false, function(json) {
|
||||
var nodes = $('#nodes');
|
||||
for (node in json) {
|
||||
nodes.append("<option value='" + json[node] + "'>" + json[node] + "</option>");
|
||||
}
|
||||
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("<option value='" + data + "'>" + data + "</option>");
|
||||
var option = nodes.get(0).options[data];
|
||||
option.selected = true;
|
||||
nodes.change();
|
||||
});
|
||||
return false;
|
||||
});
|
||||
});})
|
||||
|
|
@ -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 <tangle>
|
||||
[ make-sandbox ] [ <tangle-dispatcher> ] bi
|
||||
main-responder set ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
A web framework using semantic-db as a backend
|
||||
|
|
@ -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 >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
|
||||
[ 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
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
! 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 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 )
|
||||
GENERIC: render ( content templater -- )
|
||||
|
||||
TUPLE: echo-template ;
|
||||
C: <echo-template> echo-template
|
||||
|
||||
M: echo-template render* drop ;
|
||||
! METHOD: render* { string echo-template } drop ;
|
||||
M: object render render* write ;
|
||||
|
||||
TUPLE: tangle db seq templater ;
|
||||
C: <tangle> tangle
|
||||
|
||||
: with-tangle ( tangle quot -- )
|
||||
[ [ db>> ] [ seq>> ] bi ] dip with-db ;
|
||||
|
||||
: <text-response> ( text -- response )
|
||||
"text/plain" <content> swap >>body ;
|
||||
|
||||
: node-response ( id -- response )
|
||||
load-node [ node-content <text-response> ] [ <404> ] if* ;
|
||||
|
||||
: 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 <text-response>
|
||||
] [
|
||||
drop <400>
|
||||
] if
|
||||
] [
|
||||
<400>
|
||||
] if* ;
|
||||
|
||||
: <node-responder> ( -- responder )
|
||||
<action> [ params get display-node ] >>display
|
||||
[ params get submit-node ] >>submit ;
|
||||
|
||||
TUPLE: path-responder ;
|
||||
C: <path-responder> path-responder
|
||||
|
||||
M: path-responder call-responder* ( path responder -- response )
|
||||
drop path>file [ node-content <text-response> ] [ <404> ] if* ;
|
||||
|
||||
: <json-response> ( obj -- response )
|
||||
"application/json" <content> swap >json >>body ;
|
||||
|
||||
TUPLE: tangle-dispatcher < dispatcher tangle ;
|
||||
|
||||
: <tangle-dispatcher> ( tangle -- dispatcher )
|
||||
tangle-dispatcher new-dispatcher swap >>tangle
|
||||
<path-responder> >>default
|
||||
"extra/tangle/resources" resource-path <static> "resources" add-responder
|
||||
<node-responder> "node" add-responder
|
||||
<action> [ all-node-ids <json-response> ] >>display "all" add-responder ;
|
||||
|
||||
M: tangle-dispatcher call-responder* ( path dispatcher -- response )
|
||||
dup tangle>> [
|
||||
find-responder call-responder
|
||||
] with-tangle ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
" Vim syntax file
|
||||
" Language: factor
|
||||
" Maintainer: Alex Chapman <chapman.alex@gmail.com>
|
||||
" 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 <wrapper> 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 <buckets> 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? <slice> tail-slice empty? tail* member? unclip virtual-sequence? set-length last-index* <column> 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 <flat-slice> second change-each join set-repetition-len <reversed> 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 <repetition> 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 <wrapper> 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? <enum> 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 <buckets> 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? <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 <flat-slice> second change-each join set-repetition-len <reversed> 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 <repetition> 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 <array> 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 <string> 1string string string?
|
||||
syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
|
||||
syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation <restart> ifcc continuation-name set-restart-continuation ignore-errors continuation-retain continue <continuation> 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 <condition> 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 <restart> ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue <continuation> 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 <condition> 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
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
%>" Vim syntax file
|
||||
" Language: factor
|
||||
" Maintainer: Alex Chapman <chapman.alex@gmail.com>
|
||||
" 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue