From e22bf778893a4cb0520337172b3174fe047442d1 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 23 Jan 2008 15:13:08 +1100 Subject: [PATCH 01/63] jamshred: add copyright notices --- extra/jamshred/authors.txt | 1 + extra/jamshred/game/game.factor | 2 ++ extra/jamshred/gl/gl.factor | 2 ++ extra/jamshred/jamshred.factor | 2 ++ extra/jamshred/oint/oint.factor | 2 ++ extra/jamshred/player/player.factor | 2 ++ extra/jamshred/summary.txt | 1 + extra/jamshred/tags.txt | 2 ++ extra/jamshred/tunnel/tunnel-tests.factor | 2 ++ extra/jamshred/tunnel/tunnel.factor | 2 ++ 10 files changed, 18 insertions(+) create mode 100644 extra/jamshred/authors.txt create mode 100644 extra/jamshred/summary.txt create mode 100644 extra/jamshred/tags.txt diff --git a/extra/jamshred/authors.txt b/extra/jamshred/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index fe517d68fd..f82ee91d22 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: kernel opengl arrays sequences jamshred.tunnel jamshred.player math.vectors ; IN: jamshred.game diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index da38e43392..85c5a8dbaf 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.vectors opengl opengl.gl opengl.glu sequences ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 36dd0619f0..890a0fe1ec 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: arrays jamshred.game jamshred.gl kernel math math.constants namespaces sequences timers ui ui.gadgets ui.gestures ui.render math.vectors ; diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 254be2057a..bcf4597307 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; IN: jamshred.oint diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 4daecf29a2..6cc433903e 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: colors jamshred.oint jamshred.tunnel kernel math math.constants sequences ; IN: jamshred.player diff --git a/extra/jamshred/summary.txt b/extra/jamshred/summary.txt new file mode 100644 index 0000000000..e26fc1cf8b --- /dev/null +++ b/extra/jamshred/summary.txt @@ -0,0 +1 @@ +A simple 3d tunnel racing game diff --git a/extra/jamshred/tags.txt b/extra/jamshred/tags.txt new file mode 100644 index 0000000000..8ae5957a4b --- /dev/null +++ b/extra/jamshred/tags.txt @@ -0,0 +1,2 @@ +applications +games diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 2ea8a64bd9..649a6bada7 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; IN: temporary diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 4d60a65a4a..61fef7959c 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: arrays float-arrays kernel jamshred.oint math math.functions math.ranges math.vectors math.constants random sequences vectors ; IN: jamshred.tunnel From ba4062e04b78632f883edaacb1bfd95366e0dd80 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 26 Jan 2008 00:15:11 +1100 Subject: [PATCH 02/63] Adding morse code translation code --- extra/morse/morse-docs.factor | 13 ++++ extra/morse/morse-tests.factor | 11 +++ extra/morse/morse.factor | 125 +++++++++++++++++++++++++++++++++ 3 files changed, 149 insertions(+) create mode 100644 extra/morse/morse-docs.factor create mode 100644 extra/morse/morse-tests.factor create mode 100644 extra/morse/morse.factor diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor new file mode 100644 index 0000000000..60befeb2af --- /dev/null +++ b/extra/morse/morse-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax morse ; + +HELP: ch>morse +{ $values + { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } } +{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ; + +HELP: morse>ch +{ $values + { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } } +{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ; diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor new file mode 100644 index 0000000000..97efe1afb4 --- /dev/null +++ b/extra/morse/morse-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: arrays morse strings tools.test ; + +[ "" ] [ CHAR: \\ ch>morse ] unit-test +[ "..." ] [ CHAR: s ch>morse ] unit-test +[ CHAR: s ] [ "..." morse>ch ] unit-test +[ f ] [ "..--..--.." morse>ch ] unit-test +[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test +[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test +[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor new file mode 100644 index 0000000000..fdb4bf7c4e --- /dev/null +++ b/extra/morse/morse.factor @@ -0,0 +1,125 @@ +! 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 ; +IN: morse + +morse-assoc ( -- assoc ) + morse-codes >hashtable ; + +: morse>ch-assoc ( -- assoc ) + morse-codes [ reverse ] map >hashtable ; + +PRIVATE> + +: ch>morse ( ch -- str ) + ch>lower ch>morse-assoc at* swap "" ? ; + +: morse>ch ( str -- ch ) + morse>ch-assoc at* swap f ? ; + +: >morse ( str -- str ) + [ + [ CHAR: \s , ] [ ch>morse % ] interleave + ] "" make ; + + <+> ; + +LAZY: 'morse-word' ( -- parser ) + 'morse-char' 'char-gap' list-of ; + +LAZY: 'morse-words' ( -- parser ) + 'morse-word' 'word-gap' list-of ; + +PRIVATE> + +: morse> ( str -- str ) + 'morse-words' parse car parse-result-parsed [ + [ + >string morse>ch + ] map >string + ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ; + From 9c8c79236d1818b9c932663d183ee7f8f9af0679 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 26 Jan 2008 01:13:25 +1100 Subject: [PATCH 03/63] morse: fixed docs and morse code parsing --- extra/morse/morse-docs.factor | 14 +++++++++++++- extra/morse/morse.factor | 4 ++-- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index 60befeb2af..c11ba23db7 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax morse ; +USING: help.markup help.syntax ; +IN: morse HELP: ch>morse { $values @@ -11,3 +12,14 @@ HELP: morse>ch { $values { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } } { $description "If the given string represents a morse code character, then return that character, otherwise return f" } ; + +HELP: >morse +{ $values + { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } } +{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." } +{ $see-also morse> ch>morse } ; + +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 } ; diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index fdb4bf7c4e..e88e2f6c83 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -88,7 +88,7 @@ PRIVATE> : dot ( -- ch ) CHAR: . ; : dash ( -- ch ) CHAR: - ; : char-gap ( -- ch ) CHAR: \s ; -: word-gap ( -- ch ) " / " ; +: word-gap ( -- ch ) CHAR: / ; : =parser ( obj -- parser ) [ = ] curry satisfy ; @@ -103,7 +103,7 @@ LAZY: 'char-gap' ( -- parser ) char-gap =parser ; LAZY: 'word-gap' ( -- parser ) - word-gap token ; + word-gap =parser ; LAZY: 'morse-char' ( -- parser ) 'dot' 'dash' <|> <+> ; From 9301d62795ca60e4498600bb7b64dd198d970e42 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 26 Jan 2008 01:21:04 +1100 Subject: [PATCH 04/63] some fixes to gap-buffer --- .../cursortree/cursortree-tests.factor | 14 + extra/gap-buffer/cursortree/cursortree.factor | 91 ++++++ extra/gap-buffer/cursortree/summary.txt | 1 + extra/gap-buffer/gap-buffer-tests.factor | 40 +++ extra/gap-buffer/gap-buffer.factor | 271 ++++++++++++++++++ extra/gap-buffer/summary.txt | 1 + extra/gap-buffer/tags.txt | 1 + 7 files changed, 419 insertions(+) create mode 100644 extra/gap-buffer/cursortree/cursortree-tests.factor create mode 100644 extra/gap-buffer/cursortree/cursortree.factor create mode 100644 extra/gap-buffer/cursortree/summary.txt create mode 100644 extra/gap-buffer/gap-buffer-tests.factor create mode 100644 extra/gap-buffer/gap-buffer.factor create mode 100644 extra/gap-buffer/summary.txt create mode 100644 extra/gap-buffer/tags.txt diff --git a/extra/gap-buffer/cursortree/cursortree-tests.factor b/extra/gap-buffer/cursortree/cursortree-tests.factor new file mode 100644 index 0000000000..36b5efd7fa --- /dev/null +++ b/extra/gap-buffer/cursortree/cursortree-tests.factor @@ -0,0 +1,14 @@ +USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ; + +[ t ] [ "this is a test string" 0 at-beginning? ] unit-test +[ t ] [ "this is a test string" dup length at-end? ] unit-test +[ 3 ] [ "this is a test string" 3 cursor-pos ] unit-test +[ CHAR: i ] [ "this is a test string" 3 element< ] unit-test +[ CHAR: s ] [ "this is a test string" 3 element> ] unit-test +[ t ] [ "this is a test string" 3 CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test +[ t ] [ "this is a test string" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test +[ "this is no longer a test string" ] [ "this is a test string" 8 "no longer " over insert cursor-tree >string ] unit-test +[ "refactor" ] [ "factor" 0 CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test +[ "refactor" ] [ "factor" 0 CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test +[ "this a test string" 5 ] [ "this is a test string" 5 dup delete> dup delete> dup delete> dup cursor-tree >string swap cursor-pos ] unit-test +[ "this a test string" 5 ] [ "this is a test string" 8 dup delete< dup delete< dup delete< dup cursor-tree >string swap cursor-pos ] unit-test diff --git a/extra/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor new file mode 100644 index 0000000000..e056cc8dee --- /dev/null +++ b/extra/gap-buffer/cursortree/cursortree.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2007 Alex Chapman All Rights Reserved. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ; +IN: gap-buffer.cursortree + +TUPLE: cursortree cursors ; + +: ( seq -- cursortree ) + cursortree construct-empty tuck set-delegate + over set-cursortree-cursors ; + +GENERIC: cursortree-gb ( cursortree -- gb ) +M: cursortree cursortree-gb ( cursortree -- gb ) delegate ; +GENERIC: set-cursortree-gb ( gb cursortree -- ) +M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ; + +TUPLE: cursor i tree ; +TUPLE: left-cursor ; +TUPLE: right-cursor ; + +: cursor-index ( cursor -- i ) cursor-i ; inline + +: add-cursor ( cursortree cursor -- ) dup cursor-index rot avl-insert ; + +: remove-cursor ( cursortree cursor -- ) + cursor-index swap delete-at ; + ! dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ; + +: set-cursor-index ( index cursor -- ) + dup cursor-tree over remove-cursor tuck set-cursor-i + dup cursor-tree cursortree-cursors swap add-cursor ; + +GENERIC: cursor-pos ( cursor -- n ) +GENERIC: set-cursor-pos ( n cursor -- ) +M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ; +M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ; +M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ; +M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ; + +: ( cursortree -- cursor ) + cursor construct-empty tuck set-cursor-tree ; + +: make-cursor ( cursortree pos cursor -- cursor ) + >r swap r> tuck set-delegate tuck set-cursor-pos ; + +: ( cursortree pos -- left-cursor ) + left-cursor construct-empty make-cursor ; + +: ( cursortree pos -- right-cursor ) + right-cursor construct-empty make-cursor ; + +: cursor-positions ( cursortree -- seq ) + cursortree-cursors tree-values [ cursor-pos ] map ; + +M: cursortree move-gap ( n cursortree -- ) + #! Get the position of each cursor before the move, then re-set the + #! position afterwards. This will update any changed cursor indices. + dup cursor-positions >r tuck cursortree-gb move-gap + cursortree-cursors tree-values r> swap [ set-cursor-pos ] 2each ; + +: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ; +: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ; + +: at-beginning? ( cursor -- ? ) cursor-pos 0 = ; +: at-end? ( cursor -- ? ) element@> length = ; + +: insert ( obj cursor -- ) element@> insert* ; + +: element< ( cursor -- elem ) element@< nth ; +: element> ( cursor -- elem ) element@> nth ; + +: set-element< ( elem cursor -- ) element@< set-nth ; +: set-element> ( elem cursor -- ) element@> set-nth ; + +GENERIC: fix-cursor ( cursortree cursor -- ) + +M: left-cursor fix-cursor ( cursortree cursor -- ) + >r gb-gap-start 1- r> set-cursor-index ; + +M: right-cursor fix-cursor ( cursortree cursor -- ) + >r gb-gap-end r> set-cursor-index ; + +: fix-cursors ( old-gap-end cursortree -- ) + tuck cursortree-cursors tree-get-all [ fix-cursor ] curry* each ; + +M: cursortree delete* ( pos cursortree -- ) + tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ; + +: delete< ( cursor -- ) element@< delete* ; +: delete> ( cursor -- ) element@> delete* ; + diff --git a/extra/gap-buffer/cursortree/summary.txt b/extra/gap-buffer/cursortree/summary.txt new file mode 100644 index 0000000000..e57688fad0 --- /dev/null +++ b/extra/gap-buffer/cursortree/summary.txt @@ -0,0 +1 @@ +Collection of 'cursors' representing locations in a gap buffer diff --git a/extra/gap-buffer/gap-buffer-tests.factor b/extra/gap-buffer/gap-buffer-tests.factor new file mode 100644 index 0000000000..85dc7b3c88 --- /dev/null +++ b/extra/gap-buffer/gap-buffer-tests.factor @@ -0,0 +1,40 @@ +USING: kernel sequences tools.test gap-buffer strings math ; + +! test copy-elements +[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test +[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test +[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test + +! test sequence protocol (like, length, nth, set-nth) +[ "gap buffers are cool" ] [ "gap buffers are cool" "" like ] unit-test + +! test move-gap-back-inside +[ t f ] [ 5 "0123456" move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test +[ "0123456" ] [ "0123456" 5 over move-gap >string ] unit-test +! test move-gap-forward-inside +[ t ] [ "I once ate a spaniel" 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test +[ "I once ate a spaniel" ] [ "I once ate a spaniel" 15 over move-gap 17 over move-gap >string ] unit-test +! test move-gap-back-around +[ f f ] [ 2 "terriers are ok too" move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test +[ "terriers are ok too" ] [ "terriers are ok too" 2 over move-gap >string ] unit-test +! test move-gap-forward-around +[ f t ] [ "god is nam's best friend" 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test +[ "god is nam's best friend" ] [ "god is nam's best friend" 2 over move-gap 22 over move-gap >string ] unit-test + +! test changing buffer contents +[ "factory" ] [ "factor" CHAR: y 6 pick insert* >string ] unit-test +! test inserting multiple elements in different places. buffer should grow +[ "refractory" ] [ "factor" CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test +! test deleting elements. buffer should shrink +[ "for" ] [ "factor" 3 [ 1 over delete* ] times >string ] unit-test +! more testing of nth and set-nth +[ "raptor" ] [ "factor" CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test + +! test stack/queue operations +[ "slaughter" ] [ "laughter" CHAR: s over push-start >string ] unit-test +[ "pantonio" ] [ "pant" "onio" over push-end >string ] unit-test +[ CHAR: f "actor" ] [ "factor" dup pop-start swap >string ] unit-test +[ CHAR: s "pant" ] [ "pants" dup pop-end swap >string ] unit-test +[ "end this is the " ] [ "this is the end " 4 over rotate >string ] unit-test +[ "your jedi training is finished " ] [ "finished your jedi training is " -9 over rotate >string ] unit-test + diff --git a/extra/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor new file mode 100644 index 0000000000..99051ea678 --- /dev/null +++ b/extra/gap-buffer/gap-buffer.factor @@ -0,0 +1,271 @@ +! Copyright (C) 2007 Alex Chapman All Rights Reserved. +! See http://factorcode.org/license.txt for BSD license. +! +! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain +! for a good introduction see: +! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf +USING: kernel arrays sequences sequences.private circular math math.functions generic ; +IN: gap-buffer + +! gap-start -- the first element of the gap +! gap-end -- the first element after the gap +! expand-factor -- should be > 1 +! min-size -- < 5 is not sensible + +TUPLE: gb + gap-start + gap-end + expand-factor + min-size ; + +GENERIC: gb-seq ( gb -- seq ) +GENERIC: set-gb-seq ( seq gb -- ) +M: gb gb-seq ( gb -- seq ) delegate ; +M: gb set-gb-seq ( seq gb -- ) set-delegate ; + +: required-space ( n gb -- n ) + tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ; + +: ( seq -- gb ) + gb construct-empty + 5 over set-gb-min-size + 1.5 over set-gb-expand-factor + [ >r length r> set-gb-gap-start ] 2keep + [ swap length over required-space swap set-gb-gap-end ] 2keep + [ + over length over required-space rot { } like resize-array swap set-gb-seq + ] keep ; + +M: gb like ( seq gb -- seq ) drop ; + +: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ; + +: buffer-length ( gb -- n ) gb-seq length ; + +M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ; + +: position>index ( pos gb -- i ) + 2dup gb-gap-start >= [ + gap-length + + ] [ drop ] if ; + +: index>position ( i gb -- pos ) + 2dup gb-gap-end >= [ + gap-length - + ] [ drop ] if ; + +M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ; + +M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ; + +M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ; + +M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ; + +M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ; + +M: gb virtual-seq gb-seq ; + +INSTANCE: gb virtual-sequence + +! ------------- moving the gap ------------------------------- + +: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ; + +: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ; + +: copy-elements-back ( dst start seq n -- ) + dup 0 > [ + >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back + ] [ 3drop drop ] if ; + +: copy-elements-forward ( dst start seq n -- ) + dup 0 > [ + >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward + ] [ 3drop drop ] if ; + +: copy-elements ( dst start end seq -- ) + pick pick > [ + >r dupd - r> swap copy-elements-forward + ] [ + >r over - r> swap copy-elements-back + ] if ; + +! the gap can be moved either forward or back. Moving the gap 'inside' means +! moving elements across the gap. Moving the gap 'around' means changing the +! start of the circular buffer to avoid moving as many elements. + +! We decide which method (inside or around) to pick based on the number of +! elements that will need to be moved. We always try to move as few elements as +! possible. + +: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ; + +: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ; + +: move-gap-back-inside? ( i gb -- i gb ? ) + #! is it cheaper to move the gap inside than around? + 2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ; + +: move-gap-forward-inside? ( i gb -- i gb ? ) + #! is it cheaper to move the gap inside than around? + 2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ; + +: move-gap-forward-inside ( i gb -- ) + [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ; + +: move-gap-back-inside ( i gb -- ) + [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ; + +: move-gap-forward-around ( i gb -- ) + 0 over move-gap-back-inside [ + dup buffer-length [ + swap gap-length - neg swap + ] keep + ] keep [ + gb-seq copy-elements + ] keep dup gap-length swap gb-seq change-circular-start ; + +: move-gap-back-around ( i gb -- ) + dup buffer-length over move-gap-forward-inside [ + length swap -1 + ] keep [ + gb-seq copy-elements + ] keep dup length swap gb-seq change-circular-start ; + +: move-gap-forward ( i gb -- ) + move-gap-forward-inside? [ + move-gap-forward-inside + ] [ + move-gap-forward-around + ] if ; + +: move-gap-back ( i gb -- ) + move-gap-back-inside? [ + move-gap-back-inside + ] [ + move-gap-back-around + ] if ; + +: (move-gap) ( i gb -- ) + move-gap? [ + move-gap-forward? [ + move-gap-forward + ] [ + move-gap-back + ] if + ] [ 2drop ] if ; + +: fix-gap ( n gb -- ) + 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ; + +GENERIC: move-gap ( n gb -- ) + +M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ; + +! ------------ resizing ------------------------------------- + +: enough-room? ( n gb -- ? ) + #! is there enough room to add 'n' elements to gb? + tuck length + swap buffer-length <= ; + +: set-new-gap-end ( array gb -- ) + [ buffer-length swap length swap - ] keep + [ gb-gap-end + ] keep set-gb-gap-end ; + +: after-gap ( gb -- gb ) + dup gb-seq swap gb-gap-end tail ; + +: before-gap ( gb -- gb ) + dup gb-gap-start head ; + +: copy-after-gap ( array gb -- ) + #! copy everything after the gap in 'gb' into the end of 'array', + #! and change 'gb's gap-end to reflect the gap-end in 'array' + dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ; + +: copy-before-gap ( array gb -- ) + #! copy everything before the gap in 'gb' into the start of 'array' + before-gap 0 rot copy ; ! gap start doesn't change + +: resize-buffer ( gb new-size -- ) + f swap 2dup copy-before-gap 2dup copy-after-gap + >r r> set-gb-seq ; + +: decrease-buffer-size ( gb -- ) + #! the gap is too big, so resize to something sensible + dup length over required-space resize-buffer ; + +: increase-buffer-size ( n gb -- ) + #! increase the buffer to fit at least 'n' more elements + tuck length + over required-space resize-buffer ; + +: gb-too-big? ( gb -- ? ) + dup buffer-length over gb-min-size > [ + dup length over buffer-length rot gb-expand-factor sq / < + ] [ drop f ] if ; + +: ?decrease ( gb -- ) + dup gb-too-big? [ + decrease-buffer-size + ] [ drop ] if ; + +: ensure-room ( n gb -- ) + #! ensure that ther will be enough room for 'n' more elements + 2dup enough-room? [ 2drop ] [ + increase-buffer-size + ] if ; + +! ------- editing operations --------------- + +GENERIC# insert* 2 ( seq position gb -- ) + +: prepare-insert ( seq position gb -- seq gb ) + tuck move-gap over length over ensure-room ; + +: insert-elements ( seq gb -- ) + dup gb-gap-start swap gb-seq copy ; + +: increment-gap-start ( gb n -- ) + over gb-gap-start + swap set-gb-gap-start ; + +! generic dispatch identifies numbers as sequences before numbers... +! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ; +: number-insert ( num position gb -- ) >r >r 1array r> r> insert* ; + +M: sequence insert* ( seq position gb -- ) + pick number? [ + number-insert + ] [ + prepare-insert [ insert-elements ] 2keep swap length increment-gap-start + ] if ; + +: (delete*) ( gb -- ) + dup gb-gap-end 1+ over set-gb-gap-end ?decrease ; + +GENERIC: delete* ( pos gb -- ) + +M: gb delete* ( position gb -- ) + tuck move-gap (delete*) ; + +! -------- stack/queue operations ----------- + +: push-start ( obj gb -- ) 0 swap insert* ; + +: push-end ( obj gb -- ) [ length ] keep insert* ; + +: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ; + +: pop-start ( gb -- elem ) 0 swap pop-elem ; + +: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ; + +: rotate ( n gb -- ) + dup length 1 > [ + swap dup 0 > [ + [ dup [ pop-end ] keep push-start ] + ] [ + neg [ dup [ pop-start ] keep push-end ] + ] if times drop + ] [ 2drop ] if ; + diff --git a/extra/gap-buffer/summary.txt b/extra/gap-buffer/summary.txt new file mode 100644 index 0000000000..0da4c0075d --- /dev/null +++ b/extra/gap-buffer/summary.txt @@ -0,0 +1 @@ +Gap buffer data structure diff --git a/extra/gap-buffer/tags.txt b/extra/gap-buffer/tags.txt new file mode 100644 index 0000000000..57de004d91 --- /dev/null +++ b/extra/gap-buffer/tags.txt @@ -0,0 +1 @@ +collections sequences From f8aeb280e7f909a5bd3f7d5ab9573e3bfe1c3c07 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 26 Jan 2008 01:21:56 +1100 Subject: [PATCH 05/63] adding a couple of authors.txts to gap-buffer --- extra/gap-buffer/authors.txt | 1 + extra/gap-buffer/cursortree/authors.txt | 1 + 2 files changed, 2 insertions(+) create mode 100644 extra/gap-buffer/authors.txt create mode 100644 extra/gap-buffer/cursortree/authors.txt diff --git a/extra/gap-buffer/authors.txt b/extra/gap-buffer/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/gap-buffer/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/gap-buffer/cursortree/authors.txt b/extra/gap-buffer/cursortree/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/gap-buffer/cursortree/authors.txt @@ -0,0 +1 @@ +Alex Chapman From 1740408a179f14c9ad9c0932694bdc00c05d8c17 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 26 Jan 2008 01:22:36 +1100 Subject: [PATCH 06/63] removing gap-buffer from unmaintained directory --- unmaintained/gap-buffer/authors.txt | 1 - .../gap-buffer/cursortree/authors.txt | 1 - .../cursortree/cursortree-tests.factor | 14 - .../gap-buffer/cursortree/cursortree.factor | 90 ------ .../gap-buffer/cursortree/summary.txt | 1 - .../gap-buffer/gap-buffer-tests.factor | 40 --- unmaintained/gap-buffer/gap-buffer.factor | 271 ------------------ unmaintained/gap-buffer/summary.txt | 1 - unmaintained/gap-buffer/tags.txt | 1 - 9 files changed, 420 deletions(-) delete mode 100644 unmaintained/gap-buffer/authors.txt delete mode 100644 unmaintained/gap-buffer/cursortree/authors.txt delete mode 100644 unmaintained/gap-buffer/cursortree/cursortree-tests.factor delete mode 100644 unmaintained/gap-buffer/cursortree/cursortree.factor delete mode 100644 unmaintained/gap-buffer/cursortree/summary.txt delete mode 100644 unmaintained/gap-buffer/gap-buffer-tests.factor delete mode 100644 unmaintained/gap-buffer/gap-buffer.factor delete mode 100644 unmaintained/gap-buffer/summary.txt delete mode 100644 unmaintained/gap-buffer/tags.txt diff --git a/unmaintained/gap-buffer/authors.txt b/unmaintained/gap-buffer/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/unmaintained/gap-buffer/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/gap-buffer/cursortree/authors.txt b/unmaintained/gap-buffer/cursortree/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/unmaintained/gap-buffer/cursortree/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/gap-buffer/cursortree/cursortree-tests.factor b/unmaintained/gap-buffer/cursortree/cursortree-tests.factor deleted file mode 100644 index 36b5efd7fa..0000000000 --- a/unmaintained/gap-buffer/cursortree/cursortree-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ; - -[ t ] [ "this is a test string" 0 at-beginning? ] unit-test -[ t ] [ "this is a test string" dup length at-end? ] unit-test -[ 3 ] [ "this is a test string" 3 cursor-pos ] unit-test -[ CHAR: i ] [ "this is a test string" 3 element< ] unit-test -[ CHAR: s ] [ "this is a test string" 3 element> ] unit-test -[ t ] [ "this is a test string" 3 CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test -[ t ] [ "this is a test string" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test -[ "this is no longer a test string" ] [ "this is a test string" 8 "no longer " over insert cursor-tree >string ] unit-test -[ "refactor" ] [ "factor" 0 CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test -[ "refactor" ] [ "factor" 0 CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test -[ "this a test string" 5 ] [ "this is a test string" 5 dup delete> dup delete> dup delete> dup cursor-tree >string swap cursor-pos ] unit-test -[ "this a test string" 5 ] [ "this is a test string" 8 dup delete< dup delete< dup delete< dup cursor-tree >string swap cursor-pos ] unit-test diff --git a/unmaintained/gap-buffer/cursortree/cursortree.factor b/unmaintained/gap-buffer/cursortree/cursortree.factor deleted file mode 100644 index de567702a8..0000000000 --- a/unmaintained/gap-buffer/cursortree/cursortree.factor +++ /dev/null @@ -1,90 +0,0 @@ -! Copyright (C) 2007 Alex Chapman All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel gap-buffer generic trees trees.avl-tree math sequences quotations ; -IN: gap-buffer.cursortree - -TUPLE: cursortree cursors ; - -: ( seq -- cursortree ) - cursortree construct-empty tuck set-delegate - over set-cursortree-cursors ; - -GENERIC: cursortree-gb ( cursortree -- gb ) -M: cursortree cursortree-gb ( cursortree -- gb ) delegate ; -GENERIC: set-cursortree-gb ( gb cursortree -- ) -M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ; - -TUPLE: cursor i tree ; -TUPLE: left-cursor ; -TUPLE: right-cursor ; - -: cursor-index ( cursor -- i ) cursor-i ; inline - -: add-cursor ( cursortree cursor -- ) dup cursor-index rot tree-insert ; - -: remove-cursor ( cursortree cursor -- ) - dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ; - -: set-cursor-index ( index cursor -- ) - dup cursor-tree over remove-cursor tuck set-cursor-i - dup cursor-tree cursortree-cursors swap add-cursor ; - -GENERIC: cursor-pos ( cursor -- n ) -GENERIC: set-cursor-pos ( n cursor -- ) -M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ; -M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ; -M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ; -M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ; - -: ( cursortree -- cursor ) - cursor construct-empty tuck set-cursor-tree ; - -: make-cursor ( cursortree pos cursor -- cursor ) - >r swap r> tuck set-delegate tuck set-cursor-pos ; - -: ( cursortree pos -- left-cursor ) - left-cursor construct-empty make-cursor ; - -: ( cursortree pos -- right-cursor ) - right-cursor construct-empty make-cursor ; - -: cursor-positions ( cursortree -- seq ) - cursortree-cursors tree-values [ cursor-pos ] map ; - -M: cursortree move-gap ( n cursortree -- ) - #! Get the position of each cursor before the move, then re-set the - #! position afterwards. This will update any changed cursor indices. - dup cursor-positions >r tuck cursortree-gb move-gap - cursortree-cursors tree-values r> swap [ set-cursor-pos ] 2each ; - -: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ; -: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ; - -: at-beginning? ( cursor -- ? ) cursor-pos 0 = ; -: at-end? ( cursor -- ? ) element@> length = ; - -: insert ( obj cursor -- ) element@> insert* ; - -: element< ( cursor -- elem ) element@< nth ; -: element> ( cursor -- elem ) element@> nth ; - -: set-element< ( elem cursor -- ) element@< set-nth ; -: set-element> ( elem cursor -- ) element@> set-nth ; - -GENERIC: fix-cursor ( cursortree cursor -- ) - -M: left-cursor fix-cursor ( cursortree cursor -- ) - >r gb-gap-start 1- r> set-cursor-index ; - -M: right-cursor fix-cursor ( cursortree cursor -- ) - >r gb-gap-end r> set-cursor-index ; - -: fix-cursors ( old-gap-end cursortree -- ) - tuck cursortree-cursors tree-get-all [ fix-cursor ] curry* each ; - -M: cursortree delete* ( pos cursortree -- ) - tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ; - -: delete< ( cursor -- ) element@< delete* ; -: delete> ( cursor -- ) element@> delete* ; - diff --git a/unmaintained/gap-buffer/cursortree/summary.txt b/unmaintained/gap-buffer/cursortree/summary.txt deleted file mode 100644 index e57688fad0..0000000000 --- a/unmaintained/gap-buffer/cursortree/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Collection of 'cursors' representing locations in a gap buffer diff --git a/unmaintained/gap-buffer/gap-buffer-tests.factor b/unmaintained/gap-buffer/gap-buffer-tests.factor deleted file mode 100644 index 85dc7b3c88..0000000000 --- a/unmaintained/gap-buffer/gap-buffer-tests.factor +++ /dev/null @@ -1,40 +0,0 @@ -USING: kernel sequences tools.test gap-buffer strings math ; - -! test copy-elements -[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test -[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test -[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test - -! test sequence protocol (like, length, nth, set-nth) -[ "gap buffers are cool" ] [ "gap buffers are cool" "" like ] unit-test - -! test move-gap-back-inside -[ t f ] [ 5 "0123456" move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test -[ "0123456" ] [ "0123456" 5 over move-gap >string ] unit-test -! test move-gap-forward-inside -[ t ] [ "I once ate a spaniel" 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test -[ "I once ate a spaniel" ] [ "I once ate a spaniel" 15 over move-gap 17 over move-gap >string ] unit-test -! test move-gap-back-around -[ f f ] [ 2 "terriers are ok too" move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test -[ "terriers are ok too" ] [ "terriers are ok too" 2 over move-gap >string ] unit-test -! test move-gap-forward-around -[ f t ] [ "god is nam's best friend" 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test -[ "god is nam's best friend" ] [ "god is nam's best friend" 2 over move-gap 22 over move-gap >string ] unit-test - -! test changing buffer contents -[ "factory" ] [ "factor" CHAR: y 6 pick insert* >string ] unit-test -! test inserting multiple elements in different places. buffer should grow -[ "refractory" ] [ "factor" CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test -! test deleting elements. buffer should shrink -[ "for" ] [ "factor" 3 [ 1 over delete* ] times >string ] unit-test -! more testing of nth and set-nth -[ "raptor" ] [ "factor" CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test - -! test stack/queue operations -[ "slaughter" ] [ "laughter" CHAR: s over push-start >string ] unit-test -[ "pantonio" ] [ "pant" "onio" over push-end >string ] unit-test -[ CHAR: f "actor" ] [ "factor" dup pop-start swap >string ] unit-test -[ CHAR: s "pant" ] [ "pants" dup pop-end swap >string ] unit-test -[ "end this is the " ] [ "this is the end " 4 over rotate >string ] unit-test -[ "your jedi training is finished " ] [ "finished your jedi training is " -9 over rotate >string ] unit-test - diff --git a/unmaintained/gap-buffer/gap-buffer.factor b/unmaintained/gap-buffer/gap-buffer.factor deleted file mode 100644 index 75d5be4f7a..0000000000 --- a/unmaintained/gap-buffer/gap-buffer.factor +++ /dev/null @@ -1,271 +0,0 @@ -! Copyright (C) 2007 Alex Chapman All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -! -! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain -! for a good introduction see: -! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf -USING: kernel arrays sequences sequences.private circular math generic ; -IN: gap-buffer - -! gap-start -- the first element of the gap -! gap-end -- the first element after the gap -! expand-factor -- should be > 1 -! min-size -- < 5 is not sensible - -TUPLE: gb - gap-start - gap-end - expand-factor - min-size ; - -GENERIC: gb-seq ( gb -- seq ) -GENERIC: set-gb-seq ( seq gb -- ) -M: gb gb-seq ( gb -- seq ) delegate ; -M: gb set-gb-seq ( seq gb -- ) set-delegate ; - -: required-space ( n gb -- n ) - tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ; - -: ( seq -- gb ) - gb construct-empty - 5 over set-gb-min-size - 1.5 over set-gb-expand-factor - [ >r length r> set-gb-gap-start ] 2keep - [ swap length over required-space swap set-gb-gap-end ] 2keep - [ - over length over required-space rot { } like resize-array swap set-gb-seq - ] keep ; - -M: gb like ( seq gb -- seq ) drop ; - -: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ; - -: buffer-length ( gb -- n ) gb-seq length ; - -M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ; - -: position>index ( pos gb -- i ) - 2dup gb-gap-start >= [ - gap-length + - ] [ drop ] if ; - -: index>position ( i gb -- pos ) - 2dup gb-gap-end >= [ - gap-length - - ] [ drop ] if ; - -M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ; - -M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ; - -M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ; - -M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ; - -M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ; - -M: gb virtual-seq gb-seq ; - -INSTANCE: gb virtual-sequence - -! ------------- moving the gap ------------------------------- - -: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ; - -: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ; - -: copy-elements-back ( dst start seq n -- ) - dup 0 > [ - >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back - ] [ 3drop drop ] if ; - -: copy-elements-forward ( dst start seq n -- ) - dup 0 > [ - >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward - ] [ 3drop drop ] if ; - -: copy-elements ( dst start end seq -- ) - pick pick > [ - >r dupd - r> swap copy-elements-forward - ] [ - >r over - r> swap copy-elements-back - ] if ; - -! the gap can be moved either forward or back. Moving the gap 'inside' means -! moving elements across the gap. Moving the gap 'around' means changing the -! start of the circular buffer to avoid moving as many elements. - -! We decide which method (inside or around) to pick based on the number of -! elements that will need to be moved. We always try to move as few elements as -! possible. - -: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ; - -: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ; - -: move-gap-back-inside? ( i gb -- i gb ? ) - #! is it cheaper to move the gap inside than around? - 2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ; - -: move-gap-forward-inside? ( i gb -- i gb ? ) - #! is it cheaper to move the gap inside than around? - 2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ; - -: move-gap-forward-inside ( i gb -- ) - [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ; - -: move-gap-back-inside ( i gb -- ) - [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ; - -: move-gap-forward-around ( i gb -- ) - 0 over move-gap-back-inside [ - dup buffer-length [ - swap gap-length - neg swap - ] keep - ] keep [ - gb-seq copy-elements - ] keep dup gap-length swap gb-seq change-circular-start ; - -: move-gap-back-around ( i gb -- ) - dup buffer-length over move-gap-forward-inside [ - length swap -1 - ] keep [ - gb-seq copy-elements - ] keep dup length swap gb-seq change-circular-start ; - -: move-gap-forward ( i gb -- ) - move-gap-forward-inside? [ - move-gap-forward-inside - ] [ - move-gap-forward-around - ] if ; - -: move-gap-back ( i gb -- ) - move-gap-back-inside? [ - move-gap-back-inside - ] [ - move-gap-back-around - ] if ; - -: (move-gap) ( i gb -- ) - move-gap? [ - move-gap-forward? [ - move-gap-forward - ] [ - move-gap-back - ] if - ] [ 2drop ] if ; - -: fix-gap ( n gb -- ) - 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ; - -GENERIC: move-gap ( n gb -- ) - -M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ; - -! ------------ resizing ------------------------------------- - -: enough-room? ( n gb -- ? ) - #! is there enough room to add 'n' elements to gb? - tuck length + swap buffer-length <= ; - -: set-new-gap-end ( array gb -- ) - [ buffer-length swap length swap - ] keep - [ gb-gap-end + ] keep set-gb-gap-end ; - -: after-gap ( gb -- gb ) - dup gb-seq swap gb-gap-end tail ; - -: before-gap ( gb -- gb ) - dup gb-gap-start head ; - -: copy-after-gap ( array gb -- ) - #! copy everything after the gap in 'gb' into the end of 'array', - #! and change 'gb's gap-end to reflect the gap-end in 'array' - dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ; - -: copy-before-gap ( array gb -- ) - #! copy everything before the gap in 'gb' into the start of 'array' - before-gap 0 rot copy ; ! gap start doesn't change - -: resize-buffer ( gb new-size -- ) - f swap 2dup copy-before-gap 2dup copy-after-gap - >r r> set-gb-seq ; - -: decrease-buffer-size ( gb -- ) - #! the gap is too big, so resize to something sensible - dup length over required-space resize-buffer ; - -: increase-buffer-size ( n gb -- ) - #! increase the buffer to fit at least 'n' more elements - tuck length + over required-space resize-buffer ; - -: gb-too-big? ( gb -- ? ) - dup buffer-length over gb-min-size > [ - dup length over buffer-length rot gb-expand-factor sq / < - ] [ drop f ] if ; - -: ?decrease ( gb -- ) - dup gb-too-big? [ - decrease-buffer-size - ] [ drop ] if ; - -: ensure-room ( n gb -- ) - #! ensure that ther will be enough room for 'n' more elements - 2dup enough-room? [ 2drop ] [ - increase-buffer-size - ] if ; - -! ------- editing operations --------------- - -GENERIC# insert* 2 ( seq position gb -- ) - -: prepare-insert ( seq position gb -- seq gb ) - tuck move-gap over length over ensure-room ; - -: insert-elements ( seq gb -- ) - dup gb-gap-start swap gb-seq copy ; - -: increment-gap-start ( gb n -- ) - over gb-gap-start + swap set-gb-gap-start ; - -! generic dispatch identifies numbers as sequences before numbers... -! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ; -: number-insert ( num position gb -- ) >r >r 1array r> r> insert* ; - -M: sequence insert* ( seq position gb -- ) - pick number? [ - number-insert - ] [ - prepare-insert [ insert-elements ] 2keep swap length increment-gap-start - ] if ; - -: (delete*) ( gb -- ) - dup gb-gap-end 1+ over set-gb-gap-end ?decrease ; - -GENERIC: delete* ( pos gb -- ) - -M: gb delete* ( position gb -- ) - tuck move-gap (delete*) ; - -! -------- stack/queue operations ----------- - -: push-start ( obj gb -- ) 0 swap insert* ; - -: push-end ( obj gb -- ) [ length ] keep insert* ; - -: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ; - -: pop-start ( gb -- elem ) 0 swap pop-elem ; - -: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ; - -: rotate ( n gb -- ) - dup length 1 > [ - swap dup 0 > [ - [ dup [ pop-end ] keep push-start ] - ] [ - neg [ dup [ pop-start ] keep push-end ] - ] if times drop - ] [ 2drop ] if ; - diff --git a/unmaintained/gap-buffer/summary.txt b/unmaintained/gap-buffer/summary.txt deleted file mode 100644 index 0da4c0075d..0000000000 --- a/unmaintained/gap-buffer/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Gap buffer data structure diff --git a/unmaintained/gap-buffer/tags.txt b/unmaintained/gap-buffer/tags.txt deleted file mode 100644 index 57de004d91..0000000000 --- a/unmaintained/gap-buffer/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections sequences From 84901e6dbcec870d3cb62b54200433cde2e43341 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 12 Feb 2008 23:02:33 -0500 Subject: [PATCH 07/63] Solution to Project Euler problem 47 --- extra/project-euler/047/047.factor | 95 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 8 +- 2 files changed, 99 insertions(+), 4 deletions(-) create mode 100644 extra/project-euler/047/047.factor diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor new file mode 100644 index 0000000000..ab4d206ddc --- /dev/null +++ b/extra/project-euler/047/047.factor @@ -0,0 +1,95 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.primes math.primes.factors math.ranges namespaces sequences ; +IN: project-euler.047 + +! http://projecteuler.net/index.php?section=problems&id=47 + +! DESCRIPTION +! ----------- + +! The first two consecutive numbers to have two distinct prime factors are: + +! 14 = 2 * 7 +! 15 = 3 * 5 + +! The first three consecutive numbers to have three distinct prime factors are: + +! 644 = 2² * 7 * 23 +! 645 = 3 * 5 * 43 +! 646 = 2 * 17 * 19. + +! Find the first four consecutive integers to have four distinct primes +! factors. What is the first of these numbers? + + +! SOLUTION +! -------- + +! Brute force, not sure why it's incredibly slow compared to other languages + + + +: euler047 ( -- answer ) + 4 646 consecutive ; + +! [ euler047 ] time +! 542708 ms run / 60548 ms GC time + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Use a sieve to generate prime factor counts up to a limit, then look for a +! repetition of the specified number of factors. + + >array sieve set ; + +: is-prime? ( index -- ? ) + sieve get nth zero? ; + +: multiples ( n -- seq ) + sieve get length 1- over ; + +: increment-counts ( n -- ) + multiples [ sieve get [ 1+ ] change-nth ] each ; + +: prime-tau-upto ( limit -- seq ) + dup initialize-sieve 2 swap [a,b) [ + dup is-prime? [ increment-counts ] [ drop ] if + ] each sieve get ; + +: consecutive-under ( m limit -- n/f ) + prime-tau-upto [ dup ] dip start ; + +PRIVATE> + +: euler047a ( -- answer ) + 4 1000000 consecutive-under ; + +! [ euler047a ] 100 ave-time +! 2589 ms run / 45 ms GC ave time - 100 trials + +! TODO: I don't like that you have to specify the upper bound, maybe try making +! this lazy so it will also short-circuit when it finds the answer? + +MAIN: euler047a diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index a322f69e90..5f5ffa959e 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -13,10 +13,10 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 - project-euler.045 project-euler.046 project-euler.048 project-euler.052 - project-euler.053 project-euler.056 project-euler.067 project-euler.075 - project-euler.079 project-euler.092 project-euler.097 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.045 project-euler.046 project-euler.047 project-euler.048 + project-euler.052 project-euler.053 project-euler.056 project-euler.067 + project-euler.075 project-euler.079 project-euler.092 project-euler.097 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Tue, 12 Feb 2008 23:31:10 -0500 Subject: [PATCH 08/63] Tweak Project Euler solutions to use existing words --- extra/project-euler/022/022.factor | 5 +++-- extra/project-euler/047/047.factor | 13 +++++++------ 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 5bd1797272..f3a9828e01 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: ascii io.files kernel math project-euler.common sequences sorting splitting ; +USING: ascii io.files kernel math project-euler.common sequences sequences.lib + sorting splitting ; IN: project-euler.022 ! http://projecteuler.net/index.php?section=problems&id=22 @@ -31,7 +32,7 @@ IN: project-euler.022 file-contents [ quotable? ] subset "," split ; : name-scores ( seq -- seq ) - dup length [ 1+ swap alpha-value * ] 2map ; + [ 1+ swap alpha-value * ] map-index ; PRIVATE> diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor index ab4d206ddc..98e819a7db 100644 --- a/extra/project-euler/047/047.factor +++ b/extra/project-euler/047/047.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators.lib kernel math math.primes math.primes.factors math.ranges namespaces sequences ; +USING: arrays combinators.lib kernel math math.primes math.primes.factors + math.ranges namespaces sequences ; IN: project-euler.047 ! http://projecteuler.net/index.php?section=problems&id=47 @@ -54,8 +55,8 @@ PRIVATE> ! ALTERNATE SOLUTIONS ! ------------------- -! Use a sieve to generate prime factor counts up to a limit, then look for a -! repetition of the specified number of factors. +! Use a sieve to generate prime factor counts up to an arbitrary limit, then +! look for a repetition of the specified number of factors. : euler047a ( -- answer ) - 4 1000000 consecutive-under ; + 4 200000 consecutive-under ; ! [ euler047a ] 100 ave-time -! 2589 ms run / 45 ms GC ave time - 100 trials +! 503 ms run / 5 ms GC ave time - 100 trials ! TODO: I don't like that you have to specify the upper bound, maybe try making -! this lazy so it will also short-circuit when it finds the answer? +! this lazy so it could also short-circuit when it finds the answer? MAIN: euler047a From 150b4c927299223c94eb1becbd1dae5d298b9148 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 15 Feb 2008 15:39:31 +1100 Subject: [PATCH 09/63] sqlite: some helper functions --- extra/sqlite/sqlite.factor | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/extra/sqlite/sqlite.factor b/extra/sqlite/sqlite.factor index d651ad916c..63d9d64237 100644 --- a/extra/sqlite/sqlite.factor +++ b/extra/sqlite/sqlite.factor @@ -7,8 +7,8 @@ ! executing SQL calls and obtaining results. ! IN: sqlite -USING: alien compiler kernel namespaces sequences strings sqlite.lib - alien.c-types continuations ; +USING: alien compiler io.files.tmp kernel math namespaces sequences strings + sqlite.lib alien.c-types continuations ; TUPLE: sqlite-error n message ; SYMBOL: db @@ -50,12 +50,34 @@ SYMBOL: db #! Bind the text to the parameterized value in the statement. dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ; +: sqlite-bind-int ( statement index int -- ) + sqlite3_bind_int sqlite-check-result ; + +GENERIC: sqlite-bind ( statement index obj -- ) + +M: object sqlite-bind ( statement index obj -- ) + sqlite-bind-text ; + +M: integer sqlite-bind ( statement index int -- ) + sqlite-bind-int ; + : sqlite-bind-parameter-index ( statement name -- index ) sqlite3_bind_parameter_index ; : sqlite-bind-text-by-name ( statement name text -- ) >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ; +: sqlite-bind-by-name ( statement name obj -- ) + >r dupd sqlite-bind-parameter-index r> sqlite-bind ; + +GENERIC# sqlite-bind-by-name-or-index 1 ( statement key val -- ) + +M: object sqlite-bind-by-name-or-index ( statement object val -- ) + sqlite-bind-by-name ; + +M: integer sqlite-bind-by-name-or-index ( statement integer val -- ) + sqlite-bind ; + : sqlite-finalize ( statement -- ) #! Clean up all resources related to a statement. Once called #! the statement cannot be used. All statements must be finalized @@ -77,6 +99,9 @@ SYMBOL: db #! from zero, as a string. sqlite3_column_text ; +: column-int ( statement index -- int ) + sqlite3_column_int ; + : step-complete? ( step-result -- bool ) #! Return true if the result of a sqlite3_step is #! such that the iteration has completed (ie. it is @@ -125,3 +150,7 @@ DEFER: (sqlite-map) [ db get sqlite-close ] [ ] cleanup ] with-scope ; +: with-tmp-db ( quot -- ) + ".db" [ + swap with-sqlite + ] with-tmpfile ; From 622a35ec9f18321c49e260a8a55fe73b3d76932f Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 15 Feb 2008 15:40:21 +1100 Subject: [PATCH 10/63] strings.lib: sequences of alpha and numeric chars --- extra/strings/lib/lib.factor | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index 223fdb2090..6affe067fd 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -1,4 +1,4 @@ -USING: math arrays sequences kernel splitting strings ; +USING: math arrays sequences kernel random splitting strings ; IN: strings.lib : char>digit ( c -- i ) 48 - ; @@ -12,3 +12,28 @@ IN: strings.lib : >Upper-dashes ( str -- str ) "-" split [ >Upper ] map "-" join ; + +: lower-alpha-chars ( -- seq ) + 26 [ CHAR: a + ] map ; + +: upper-alpha-chars ( -- seq ) + 26 [ CHAR: A + ] map ; + +: numeric-chars ( -- seq ) + 10 [ CHAR: 0 + ] map ; + +: alpha-chars ( -- seq ) + lower-alpha-chars upper-alpha-chars append ; + +: alphanumeric-chars ( -- seq ) + alpha-chars numeric-chars append ; + +: random-alpha-char ( -- ch ) + alpha-chars random ; + +: random-alphanumeric-char ( -- ch ) + alphanumeric-chars random ; + +: random-alphanumeric-string ( length -- str ) + [ drop random-alphanumeric-char ] map "" like ; + From 72ee9ff67ca2d50c4780f7503848635ccc25bb3e Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 15 Feb 2008 15:41:15 +1100 Subject: [PATCH 11/63] Adding temporary files in io.files.tmp --- extra/io/files/tmp/tmp-tests.factor | 5 +++++ extra/io/files/tmp/tmp.factor | 22 ++++++++++++++++++++++ 2 files changed, 27 insertions(+) create mode 100644 extra/io/files/tmp/tmp-tests.factor create mode 100644 extra/io/files/tmp/tmp.factor diff --git a/extra/io/files/tmp/tmp-tests.factor b/extra/io/files/tmp/tmp-tests.factor new file mode 100644 index 0000000000..ba2ff7046c --- /dev/null +++ b/extra/io/files/tmp/tmp-tests.factor @@ -0,0 +1,5 @@ +USING: io.files io.files.tmp kernel strings tools.test ; +IN: temporary + +[ t ] [ tmpdir string? ] unit-test +[ t f ] [ ".tmp" [ dup exists? swap ] with-tmpfile exists? ] unit-test diff --git a/extra/io/files/tmp/tmp.factor b/extra/io/files/tmp/tmp.factor new file mode 100644 index 0000000000..da1deec9a7 --- /dev/null +++ b/extra/io/files/tmp/tmp.factor @@ -0,0 +1,22 @@ +USING: continuations io io.files kernel sequences strings.lib ; +IN: io.files.tmp + +: tmpdir ( -- dirname ) + #! ensure that a tmp dir exists and return its name + #! I'm using a sub-directory of factor for crossplatconformity (windows doesn't have /tmp) + "tmp" resource-path dup directory? [ dup make-directory ] unless ; + +: touch ( filename -- ) + stream-close ; + +: tmpfile ( extension -- filename ) + 16 random-alphanumeric-string over append + tmpdir swap path+ dup exists? [ + drop tmpfile + ] [ + nip dup touch + ] if ; + +: with-tmpfile ( extension quot -- ) + #! quot should have stack effect ( filename -- ) + swap tmpfile tuck swap curry swap [ delete-file ] curry [ ] cleanup ; From f55f9525030ad3a31f596f6c9447f43a225e6754 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 15 Feb 2008 15:42:14 +1100 Subject: [PATCH 12/63] adding strings.lib tests --- extra/strings/lib/lib-tests.factor | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 extra/strings/lib/lib-tests.factor diff --git a/extra/strings/lib/lib-tests.factor b/extra/strings/lib/lib-tests.factor new file mode 100644 index 0000000000..2779e190c9 --- /dev/null +++ b/extra/strings/lib/lib-tests.factor @@ -0,0 +1,8 @@ +USING: kernel sequences strings.lib tools.test ; +IN: temporary + +[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test +[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test +[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test +[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test +[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test From daa09efcf5d0211d39a5eec6ac497938229848a4 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 15 Feb 2008 15:43:47 +1100 Subject: [PATCH 13/63] initial semantic-db stuff --- extra/semantic-db/context/context.factor | 14 ++ extra/semantic-db/db/db-tests.factor | 26 ++ extra/semantic-db/db/db.factor | 287 +++++++++++++++++++++++ 3 files changed, 327 insertions(+) create mode 100644 extra/semantic-db/context/context.factor create mode 100644 extra/semantic-db/db/db-tests.factor create mode 100644 extra/semantic-db/db/db.factor diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor new file mode 100644 index 0000000000..f4d5834665 --- /dev/null +++ b/extra/semantic-db/context/context.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: semantic-db.db ; +IN: semantic-db.context + +: all-contexts ( -- contexts ) + has-type-relation context-type relation-object-subjects ; + +: context-relations ( context -- relations ) + has-context-relation swap relation-object-subjects ; + +: get-context ( name -- context ) + context-type swap ensure-node-of-type ; + diff --git a/extra/semantic-db/db/db-tests.factor b/extra/semantic-db/db/db-tests.factor new file mode 100644 index 0000000000..303ec658a0 --- /dev/null +++ b/extra/semantic-db/db/db-tests.factor @@ -0,0 +1,26 @@ +USING: io.files kernel namespaces semantic-db.db semantic-db.db.private sqlite tools.test ; +IN: temporary + +[ "n.id" ] [ "id" "n" [ 0 column-text ] field-sql ] unit-test +[ "select n.id from nodes n where n.content = :content" ] [ + + "id" "n" [ 0 column-text ] over add-field + "nodes n" over add-table + "n.content = :content" over add-condition + query-sql +] unit-test + +[ + create-node-table create-arc-table + [ 1 ] [ "first node" create-node ] unit-test + [ 2 ] [ "second node" create-node ] unit-test + [ 3 ] [ "third node" create-node ] unit-test + [ 4 ] [ f create-node ] unit-test + [ "first node" ] [ 1 node-content ] unit-test + [ 5 ] [ 1 2 3 create-arc ] unit-test + [ { { 1 2 3 } } ] [ 2 node-arcs ] unit-test + [ { { 1 2 3 } } ] [ 3 node-arcs ] unit-test + [ { { 3 1 } } ] [ 2 node-subject-arcs ] unit-test + [ { { 2 1 } } ] [ 3 node-object-arcs ] unit-test +] +with-tmp-db diff --git a/extra/semantic-db/db/db.factor b/extra/semantic-db/db/db.factor new file mode 100644 index 0000000000..5616f07a1c --- /dev/null +++ b/extra/semantic-db/db/db.factor @@ -0,0 +1,287 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs kernel math namespaces sequences sqlite ; +IN: semantic-db.db + +! sqlite utils +: prepare ( string -- statement ) + db get swap sqlite-prepare ; + +: binding ( statement key val -- statement ) + >r dup integer? [ 1+ ] when dupd r> sqlite-bind-by-name-or-index ; + +GENERIC# bindings 1 ( bindings statement -- statement ) + +M: assoc bindings + swap [ binding ] assoc-each ; + +M: sequence bindings + swap dup length swap [ binding ] 2each ; + +: prepare-with-bindings ( bindings string -- statement ) + prepare bindings ; + +: select-with-bindings ( bindings string quot -- results ) + >r prepare-with-bindings dup r> sqlite-map swap sqlite-finalize ; + +: ignore-and-finalize ( statement -- ) + dup [ drop ] sqlite-each sqlite-finalize ; + +: sql-update ( string -- ) + prepare ignore-and-finalize ; + +: update-with-bindings ( bindings string -- ) + prepare-with-bindings ignore-and-finalize ; + +: 1result ( array -- result ) + #! return the first (and hopefully only) element of the array, or f + dup length 0 > [ first ] [ drop f ] if ; + +: (collect-int-columns) ( statement n -- ) + [ dupd column-int , ] each drop ; + +: collect-int-columns ( statement n -- columns ) + [ (collect-int-columns) ] { } make ; + +! queries +TUPLE: field name table retriever ; +C: field + +TUPLE: query fields tables conditions args statement results ; + +: call-field-retrievers ( query + +: ( -- query ) + V{ } clone V{ } clone V{ } clone H{ } clone f f + query construct-boa ; + +: invalidate-query ( query -- query ) + f over set-query-results ; + +: add-field ( field query -- ) invalidate-query query-fields push ; +: ,field ( name table retriever -- ) query get add-field ; + +: add-table ( table query -- ) invalidate-query query-tables push ; +: ,table ( table -- ) query get add-table ; + +: add-condition ( condition query -- ) invalidate-query query-conditions push ; +: ,condition ( condition -- ) query get add-condition ; + +: add-arg ( arg key query -- ) invalidate-query query-args set-at ; +: ,arg ( arg key -- ) query get add-arg ; + + + +: run-query ( query -- ) + dup prepare-query dup bind-query dup retrieve finalize-query ; + +: get-results ( query -- results ) + dup query-results [ nip ] [ dup run-query query-results ] if* ; + +: with-query ( quot -- results ) + [ + query set + call + query get get-results + ] with-scope ; + +! nodes and arcs + +! maybe merge nodes and arcs table, so arcs can be nodes too: +! create table nodes (id integer primary key autoincrement, value none, type integer, subject integer, object integer) +! nodes: +! value: node content +! type: nid of node type +! subject: null +! object: null +! +! arcs: +! value: ordinality, or null +! type: nid of relation +! subject: nid of arc subject +! object: nid of arc object +! +! An alternative layout: +! +! nodes: +! id +! type +! +! content: +! id +! content +! +! arcs: +! id +! relation +! subject +! object +! ordinal +! +! A third alternative. In this, all arcs have an entry in the nodes table, but +! their content is null. No node that isn't an arc can have null content. If an +! arc needs an ordinal, then it can be created as another arc. +! +! nodes: +! id +! content +! +! arcs: +! id +! relation +! subject +! object + +: create-node-table ( -- ) + "create table nodes (id integer primary key autoincrement, content none);" sql-update ; + +: create-arc-table ( -- ) + "create table arcs (id integer, relation integer, subject integer, object integer);" sql-update ; + +: create-node ( content -- id ) + #! if content is f then it is inserted as NULL + [ 1array ] [ drop { } clone ] if* + "insert into nodes (content) values (?);" + update-with-bindings db get sqlite-last-insert-rowid ; + +: create-bootstrap-nodes ( -- ) + { "context" "relation" "is of type" "semantic-db" "is in context" } + [ create-node drop ] each ; + +: context-type 1 ; inline +: relation-type 2 ; inline +: has-type-relation 3 ; inline +: semantic-db-context 4 ; inline +: has-context-relation 5 ; inline + +: create-arc ( relation subject object -- id ) + f create-node -roll 4array + "insert into arcs (id, relation, subject, object) values (?, ?, ?, ?);" + update-with-bindings ; + +: create-bootstrap-arcs ( -- ) + has-type-relation has-type-relation relation-type create-arc drop + has-type-relation semantic-db-context context-type create-arc drop + has-context-relation has-type-relation semantic-db-context create-arc drop + has-type-relation has-context-relation relation-type create-arc drop + has-context-relation has-context-relation semantic-db-context create-arc drop ; + +: init-semantic-db ( -- ) + create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; + +: node-content ( id -- content ) + 1array "select content from nodes where id = ?" [ 0 column-text ] select-with-bindings 1result ; + +: node-arcs ( node-id -- arcs ) + 1array "select id, relation, subject, object from arcs where subject = ?1 or object = ?1;" + [ 4 collect-int-columns ] select-with-bindings ; + +: node-subject-arcs ( node-id -- arcs ) + 1array "select object, relation from arcs where subject = ?;" + [ 2 collect-int-columns ] select-with-bindings ; + +: node-object-arcs ( node-id -- arcs ) + 1array "select subject, relation from arcs where object = ?;" + [ 2 collect-int-columns ] select-with-bindings ; + +: relation-subject-objects ( relation subject -- objects ) + 2array "select object from arcs where relation = ? and subject = ?;" + [ 0 column-int ] select-with-bindings ; + +: relation-object-subjects ( relation object -- subjects ) + 2array "select subject from arcs where relation = ? and object = ?;" + [ 0 column-int ] select-with-bindings ; + +: subject-object-relations ( subject object -- relations ) + 2array "select relation from arcs where subject = ? and object = ?" + [ 0 column-int ] select-with-bindings ; + +: type-and-name-node ( type name -- node ) + has-type-relation 3array + "select n.id from arcs a, nodes n where a.subject = n.id and a.object = ? and n.name = ? and a.relation = ?" + [ 0 column-int ] select-with-bindings 1result ; + +: create-node-of-type ( type name -- node ) + create-node [ has-type-relation -rot create-arc drop ] keep ; + +: ensure-node-of-type ( type name -- node ) + 2dup type-and-name-node [ 2nip ] [ create-node-of-type ] if* ; + +: type-and-name-in-context-node ( context type name -- node ) + [ + "id" "n" [ 0 column-int ] ,field + "nodes n" ,table + "n.name = :name" ,condition + ":name" ,arg + "arcs a" ,table + "a.relation = :has_type" ,condition + has-type-relation ":has_type" ,arg + "a.subject = n.id" ,condition + "a.object = :type" ,condition + ":type" ,arg + "arcs b" ,table + "b.subject = a.relation" ,condition + "b.relation = :has_context" ,condition + has-context-relation ":has_context" ,arg + "b.object = :context" ,condition + ":context" ,arg + ] with-query 1result ; + +! ideas for an api: +! this would work something like jquery, where arcs can be selected according +! to parameters, and the contents of nodes and arcs are retrieved on demand, or +! at the program's convenience. It may be better to do this as a query language. +! TUPLE: node id content ; +! : node-text ( node -- text ) +! dup node-content [ +! nip +! ] [ +! node-id ! now get content from database, save it in node-content, and return it +! ] if* ; +! TUPLE: arc id relation subject object ; +! +! TUPLE: arcs ids relation subject object ; From 5215e3af5f927308f9726e18c8c3b237e1a46f7a Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 15 Feb 2008 17:11:28 +1100 Subject: [PATCH 14/63] io.files.tmp: update touch to use dispose instead of stream-close --- extra/io/files/tmp/tmp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/files/tmp/tmp.factor b/extra/io/files/tmp/tmp.factor index da1deec9a7..a859cfdc91 100644 --- a/extra/io/files/tmp/tmp.factor +++ b/extra/io/files/tmp/tmp.factor @@ -7,7 +7,7 @@ IN: io.files.tmp "tmp" resource-path dup directory? [ dup make-directory ] unless ; : touch ( filename -- ) - stream-close ; + dispose ; : tmpfile ( extension -- filename ) 16 random-alphanumeric-string over append From a47aa3d2889686ca37a10e970c66f2db21c26263 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 18 Feb 2008 12:35:11 +1100 Subject: [PATCH 15/63] semantic-db: using new-slots --- extra/semantic-db/db/db.factor | 96 ++++++++++++++++------------------ 1 file changed, 45 insertions(+), 51 deletions(-) diff --git a/extra/semantic-db/db/db.factor b/extra/semantic-db/db/db.factor index 5616f07a1c..df8c5b4a8a 100644 --- a/extra/semantic-db/db/db.factor +++ b/extra/semantic-db/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math namespaces sequences sqlite ; +USING: arrays assocs kernel math namespaces new-slots sequences sqlite ; IN: semantic-db.db ! sqlite utils @@ -56,37 +56,37 @@ TUPLE: query fields tables conditions args statement results ; query construct-boa ; : invalidate-query ( query -- query ) - f over set-query-results ; + f >>results ; -: add-field ( field query -- ) invalidate-query query-fields push ; -: ,field ( name table retriever -- ) query get add-field ; +: add-field ( field query -- query ) + dup invalidate-query fields>> push ; -: add-table ( table query -- ) invalidate-query query-tables push ; -: ,table ( table -- ) query get add-table ; +: add-table ( table query -- query ) + dup invalidate-query tables>> push ; -: add-condition ( condition query -- ) invalidate-query query-conditions push ; -: ,condition ( condition -- ) query get add-condition ; +: add-condition ( condition query -- query ) + tuck invalidate-query conditions>> push ; -: add-arg ( arg key query -- ) invalidate-query query-args set-at ; -: ,arg ( arg key -- ) query get add-arg ; +: add-arg ( arg key query -- query ) + [ invalidate-query args>> set-at ] keep ; > % CHAR: . , name>> % ] "" make ; : fields-sql ( query -- sql ) - query-fields dup length [ + fields>> dup length [ [ field-sql ] map ", " join ] [ drop "*" ] if ; : tables-sql ( query -- sql ) - query-tables ", " join ; + tables>> ", " join ; : conditions-sql ( query -- sql ) - query-conditions dup length [ + conditions>> dup length [ " and " join "where " swap append ] [ drop "" @@ -97,22 +97,22 @@ TUPLE: query fields tables conditions args statement results ; "select" , dup fields-sql , dup "from" , tables-sql , conditions-sql , ] { } make " " join ; -: prepare-query ( query -- ) - [ query-sql prepare ] keep set-query-statement ; +: prepare-query ( query -- query ) + dup query-sql prepare >>statement ; -: bind-query ( query -- ) - dup query-args over query-statement bindings swap set-query-statement ; +: bind-query ( query -- query ) + dup args>> over statement>> bindings >>statement ; : (retrieve) ( statement query -- result ) - query-fields swap [ field-retriever call ] curry each ; + fields>> swap [ retriever>> call ] curry each ; -: retrieve ( query -- ) - dup query-statement over [ (retrieve) ] curry sqlite-map - swap set-query-results ; - ! dup query-statement over query-retriever sqlite-map swap set-query-results ; +: retrieve ( query -- query ) + dup statement>> over [ (retrieve) ] curry sqlite-map + swap >>results ; + ! dup query-statement over query-retriever sqlite-map swap >>results ; -: finalize-query ( query -- ) - query-statement dup sqlite-finalize f swap set-query-statement ; +: finalize-query ( query -- query ) + statement>> dup sqlite-finalize f swap >>statement ; PRIVATE> @@ -120,14 +120,7 @@ PRIVATE> dup prepare-query dup bind-query dup retrieve finalize-query ; : get-results ( query -- results ) - dup query-results [ nip ] [ dup run-query query-results ] if* ; - -: with-query ( quot -- results ) - [ - query set - call - query get get-results - ] with-scope ; + dup results>> [ nip ] [ dup run-query results>> ] if* ; ! nodes and arcs @@ -252,24 +245,25 @@ PRIVATE> 2dup type-and-name-node [ 2nip ] [ create-node-of-type ] if* ; : type-and-name-in-context-node ( context type name -- node ) - [ - "id" "n" [ 0 column-int ] ,field - "nodes n" ,table - "n.name = :name" ,condition - ":name" ,arg - "arcs a" ,table - "a.relation = :has_type" ,condition - has-type-relation ":has_type" ,arg - "a.subject = n.id" ,condition - "a.object = :type" ,condition - ":type" ,arg - "arcs b" ,table - "b.subject = a.relation" ,condition - "b.relation = :has_context" ,condition - has-context-relation ":has_context" ,arg - "b.object = :context" ,condition - ":context" ,arg - ] with-query 1result ; + + "id" "n" [ 0 column-int ] add-field + "nodes n" add-table + "n.name = :name" add-condition + ":name" add-arg + "arcs a" add-table + "a.relation = :has_type" add-condition + has-type-relation ":has_type" add-arg + "a.subject = n.id" add-condition + "a.object = :type" add-condition + ":type" add-arg + "arcs b" add-table + "b.subject = a.relation" add-condition + "b.relation = :has_context" add-condition + has-context-relation ":has_context" add-arg + "b.object = :context" add-condition + ":context" add-arg + get-results 1result ; + ! ideas for an api: ! this would work something like jquery, where arcs can be selected according From 1794edfa84f710f0860e208a60d01c1b45bcef25 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 19 Feb 2008 12:08:15 +1100 Subject: [PATCH 16/63] strings.lib: adding vocab for char>upper --- extra/strings/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index 6affe067fd..7f13cd58a9 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -1,4 +1,4 @@ -USING: math arrays sequences kernel random splitting strings ; +USING: math arrays sequences kernel random splitting strings unicode.case ; IN: strings.lib : char>digit ( c -- i ) 48 - ; From cfc7ef04b574596724285802381c943e91ab4e44 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 19 Feb 2008 12:09:59 +1100 Subject: [PATCH 17/63] db.sqlite: add with-tmp-sqlite, db.tuples: some fixes --- extra/db/sqlite/sqlite.factor | 7 ++++++- extra/db/tuples/tuples.factor | 33 ++++++++++++++++++++++++--------- 2 files changed, 30 insertions(+), 10 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 4eabfc2ecd..17948bbbc4 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays assocs classes compiler db -hashtables io.files kernel math math.parser namespaces +hashtables io.files io.files.tmp kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types ; @@ -22,6 +22,11 @@ M: sqlite-db dispose ( db -- ) dispose-db ; : with-sqlite ( path quot -- ) >r r> with-db ; inline +: with-tmp-sqlite ( quot -- ) + ".db" [ + swap with-sqlite + ] with-tmpfile ; + TUPLE: sqlite-statement ; C: sqlite-statement diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 20cdd8a386..00f0f97c9e 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -12,23 +12,38 @@ TUPLE: no-slot-named ; : no-slot-named ( -- * ) T{ no-slot-named } throw ; : slot-spec-named ( str class -- slot-spec ) - "slots" word-prop [ slot-spec-name = ] with find nip - [ no-slot-named ] unless* ; + "slots" word-prop [ slot-spec-name = ] with find nip ; : offset-of-slot ( str obj -- n ) - class slot-spec-named slot-spec-offset ; + class slot-spec-named dup [ slot-spec-offset ] when ; + +DEFER: get-slot-named +: get-delegate-slot-named ( str obj -- value ) + delegate [ get-slot-named ] [ drop no-slot-named ] if* ; : get-slot-named ( str obj -- value ) - tuck offset-of-slot [ no-slot-named ] unless* slot ; + 2dup offset-of-slot [ + rot drop slot + ] [ + get-delegate-slot-named + ] if* ; + +DEFER: set-slot-named +: set-delegate-slot-named ( value str obj -- ) + delegate [ set-slot-named ] [ 2drop no-slot-named ] if* ; : set-slot-named ( value str obj -- ) - tuck offset-of-slot [ no-slot-named ] unless* set-slot ; + 2dup offset-of-slot [ + rot drop set-slot + ] [ + set-delegate-slot-named + ] if* ; : primary-key-spec ( class -- spec ) db-columns [ primary-key? ] find nip ; : primary-key ( tuple -- obj ) - dup class primary-key-spec get-slot-named ; + dup class primary-key-spec first swap get-slot-named ; : set-primary-key ( obj tuple -- ) [ class primary-key-spec first ] keep @@ -41,9 +56,9 @@ TUPLE: no-slot-named ; HOOK: create-sql db ( columns table -- seq ) HOOK: drop-sql db ( columns table -- seq ) -HOOK: insert-sql* db ( columns table -- slot-names sql ) -HOOK: update-sql* db ( columns table -- slot-names sql ) -HOOK: delete-sql* db ( columns table -- slot-names sql ) +HOOK: insert-sql* db ( columns table -- sql ) +HOOK: update-sql* db ( columns table -- sql ) +HOOK: delete-sql* db ( columns table -- sql ) HOOK: select-sql db ( tuple -- statement ) HOOK: row-column-typed db ( result-set n type -- sql ) From dd4a67d824e17400a3be5d22427bca7aed72a5dc Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 19 Feb 2008 12:12:10 +1100 Subject: [PATCH 18/63] semantic-db: changing to use db.tuples --- extra/semantic-db/context/context.factor | 2 +- extra/semantic-db/hierarchy/hierarchy.factor | 6 ++ extra/semantic-db/semantic-db-tests.factor | 11 +++ extra/semantic-db/semantic-db.factor | 81 ++++++++++++++++++++ 4 files changed, 99 insertions(+), 1 deletion(-) create mode 100644 extra/semantic-db/hierarchy/hierarchy.factor create mode 100644 extra/semantic-db/semantic-db-tests.factor create mode 100644 extra/semantic-db/semantic-db.factor diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor index f4d5834665..83da36712e 100644 --- a/extra/semantic-db/context/context.factor +++ b/extra/semantic-db/context/context.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: semantic-db.db ; +USING: semantic-db ; IN: semantic-db.context : all-contexts ( -- contexts ) diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor new file mode 100644 index 0000000000..fd4f74e33c --- /dev/null +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: kernel semantic-db ; +IN: semantic-db.hierarchy + + diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor new file mode 100644 index 0000000000..440335b2c3 --- /dev/null +++ b/extra/semantic-db/semantic-db-tests.factor @@ -0,0 +1,11 @@ +USING: accessors db db.sqlite db.tuples kernel semantic-db tools.test ; +IN: temporary + +[ + 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-tmp-sqlite diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor new file mode 100644 index 0000000000..1205648b03 --- /dev/null +++ b/extra/semantic-db/semantic-db.factor @@ -0,0 +1,81 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays db db.tuples db.types db.sqlite kernel new-slots sequences ; +IN: semantic-db + +! new semantic-db using Doug Coleman's new db abstraction library + +TUPLE: node id content ; +: ( content -- node ) + node construct-empty swap >>content ; + +node "node" +{ + { "id" "id" SERIAL +native-id+ +autoincrement+ } + { "content" "content" TEXT } +} define-persistent + +: create-node-table ( -- ) + node create-table ; + +: create-node* ( content -- id ) + dup persist id>> ; + +: create-node ( content -- ) + create-node* drop ; + +TUPLE: arc relation subject object ; + +: ( relation subject object -- arc ) + arc construct-empty + f over set-delegate + swap >>object swap >>subject swap >>relation ; + +arc "arc" +{ + { "id" "id" SERIAL +native-id+ } ! foreign key to node table? + { "relation" "relation" SERIAL +not-null+ } + { "subject" "subject" SERIAL +not-null+ } + { "object" "object" SERIAL +not-null+ } +} define-persistent + +: create-arc-table ( -- ) + arc create-table ; + ! arc db-columns maybe-remove-id arc db-table create-sql sql-command ; + +: insert-arc ( arc -- ) + dup delegate insert-tuple + [ ] [ insert-sql ] make-tuple-statement insert-statement drop ; + +: persist-arc ( arc -- ) + dup primary-key [ update-tuple ] [ insert-arc ] if ; + +: delete-arc ( arc -- ) + dup delete-tuple delegate delete-tuple ; + +: create-arc* ( relation subject object -- id ) + dup persist-arc id>> ; + +: create-arc ( relation subject object -- ) + create-arc* drop ; + +: create-bootstrap-nodes ( -- ) + { "context" "relation" "is of type" "semantic-db" "is in context" } + [ create-node ] each ; + +: context-type 1 ; inline +: relation-type 2 ; inline +: has-type-relation 3 ; inline +: semantic-db-context 4 ; inline +: has-context-relation 5 ; inline + +: create-bootstrap-arcs ( -- ) + has-type-relation has-type-relation relation-type create-arc + has-type-relation semantic-db-context context-type create-arc + has-context-relation has-type-relation semantic-db-context create-arc + has-type-relation has-context-relation relation-type create-arc + has-context-relation has-context-relation semantic-db-context create-arc ; + +: init-semantic-db ( -- ) + create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; + From aed24f565724c10e85398eff0140ffe1b104b36e Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 21 Feb 2008 20:44:15 +1100 Subject: [PATCH 19/63] latest semantic-db changes --- extra/semantic-db/context/context.factor | 14 ++++++------ extra/semantic-db/hierarchy/hierarchy.factor | 23 +++++++++++++++++++- extra/semantic-db/semantic-db-tests.factor | 10 ++++----- extra/semantic-db/semantic-db.factor | 23 +++++++------------- extra/semantic-db/type/type.factor | 19 ++++++++++++++++ 5 files changed, 61 insertions(+), 28 deletions(-) create mode 100644 extra/semantic-db/type/type.factor diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor index 83da36712e..e103fbc92e 100644 --- a/extra/semantic-db/context/context.factor +++ b/extra/semantic-db/context/context.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: semantic-db ; +USING: kernel semantic-db semantic-db.type ; IN: semantic-db.context -: all-contexts ( -- contexts ) - has-type-relation context-type relation-object-subjects ; +! : all-contexts ( -- contexts ) +! has-type-relation context-type relation-object-subjects ; +! +! : context-relations ( context -- relations ) +! has-context-relation swap relation-object-subjects ; -: context-relations ( context -- relations ) - has-context-relation swap relation-object-subjects ; - -: get-context ( name -- context ) +: ensure-context ( name -- context-id ) context-type swap ensure-node-of-type ; diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index fd4f74e33c..4feb3d8d6d 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,6 +1,27 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel semantic-db ; +USING: accessors kernel new-slots semantic-db semantic-db.context sequences ; IN: semantic-db.hierarchy +TUPLE: tree id children ; +C: tree +: hierarchy-context ( -- context-id ) + "hierarchy" ensure-context ; + +: has-parent-relation ( -- relation-id ) + ! find an arc with: + ! type = relation (in semantic-db context) + ! context = hierarchy + ! name = "has parent" + ; + +: find-children ( node-id -- children ) + ! find arcs with: + ! relation = has-parent-relation + ! object = node-id + ! then load the subjects either as nodes or subtrees + ; + +: get-node-hierarchy ( node-id -- tree ) + dup find-children ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 440335b2c3..0096b89d34 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -3,9 +3,9 @@ IN: temporary [ 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-tmp-sqlite diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 1205648b03..bd29dba5f8 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -18,12 +18,9 @@ node "node" : create-node-table ( -- ) node create-table ; -: create-node* ( content -- id ) +: create-node ( content -- id ) dup persist id>> ; -: create-node ( content -- ) - create-node* drop ; - TUPLE: arc relation subject object ; : ( relation subject object -- arc ) @@ -41,7 +38,6 @@ arc "arc" : create-arc-table ( -- ) arc create-table ; - ! arc db-columns maybe-remove-id arc db-table create-sql sql-command ; : insert-arc ( arc -- ) dup delegate insert-tuple @@ -53,15 +49,12 @@ arc "arc" : delete-arc ( arc -- ) dup delete-tuple delegate delete-tuple ; -: create-arc* ( relation subject object -- id ) +: create-arc ( relation subject object -- id ) dup persist-arc id>> ; -: create-arc ( relation subject object -- ) - create-arc* drop ; - : create-bootstrap-nodes ( -- ) { "context" "relation" "is of type" "semantic-db" "is in context" } - [ create-node ] each ; + [ create-node drop ] each ; : context-type 1 ; inline : relation-type 2 ; inline @@ -70,11 +63,11 @@ arc "arc" : has-context-relation 5 ; inline : create-bootstrap-arcs ( -- ) - has-type-relation has-type-relation relation-type create-arc - has-type-relation semantic-db-context context-type create-arc - has-context-relation has-type-relation semantic-db-context create-arc - has-type-relation has-context-relation relation-type create-arc - has-context-relation has-context-relation semantic-db-context create-arc ; + has-type-relation has-type-relation relation-type create-arc drop + has-type-relation semantic-db-context context-type create-arc drop + has-context-relation has-type-relation semantic-db-context create-arc drop + has-type-relation has-context-relation relation-type create-arc drop + has-context-relation has-context-relation semantic-db-context create-arc drop ; : init-semantic-db ( -- ) create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor new file mode 100644 index 0000000000..be4da4da83 --- /dev/null +++ b/extra/semantic-db/type/type.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: kernel semantic-db ; +IN: semantic-db.type + +: assign-type ( type nid -- arc-id ) + has-type-relation spin create-arc ; + +: create-node-of-type ( type name -- node-id ) + create-node [ assign-type drop ] keep ; + +: select-node-of-type ( type name -- node-id? ) + ! find a node with the given name, that is the subject of an arc with: + ! relation = has-type-relation + ! object = type + ; + +: ensure-node-of-type ( type name -- node-id ) + 2dup select-node-of-type [ 2nip ] [ create-node-of-type ] if* ; From 0da202f1785774212fb57570b33013080ad95a87 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 29 Feb 2008 13:51:59 +1100 Subject: [PATCH 20/63] latest db and semantic-db (not really working) --- extra/db/sqlite/sqlite.factor | 9 ++-- extra/db/tuples/tuples.factor | 7 +--- extra/semantic-db/db/db.factor | 2 +- extra/semantic-db/semantic-db-tests.factor | 10 ++++- extra/semantic-db/semantic-db.factor | 48 ++++++++++++++-------- extra/semantic-db/type/type.factor | 35 +++++++++++++--- 6 files changed, 75 insertions(+), 36 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 460b178c0e..5cb8f0c3bd 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -22,7 +22,7 @@ M: sqlite-db db-close ( handle -- ) M: sqlite-db dispose ( db -- ) dispose-db ; : with-sqlite ( path quot -- ) - >r r> with-db ; inline + sqlite-db swap with-db ; inline : with-tmp-sqlite ( quot -- ) ".db" [ @@ -33,10 +33,10 @@ TUPLE: sqlite-statement ; TUPLE: sqlite-result-set has-more? ; -M: sqlite-db ( str -- obj ) +M: sqlite-db ( str in out -- obj ) ; -M: sqlite-db ( str -- obj ) +M: sqlite-db ( str in out -- obj ) db get db-handle { set-statement-sql @@ -44,7 +44,7 @@ M: sqlite-db ( str -- obj ) set-statement-out-params set-statement-handle } statement construct - dup statement-handle over statement-sql sqlite-prepare + dup statement-handle over statement-sql sqlite-prepare over set-statement-handle sqlite-statement construct-delegate ; M: sqlite-statement dispose ( statement -- ) @@ -86,7 +86,6 @@ M: sqlite-result-set more-rows? ( result-set -- ? ) sqlite-result-set-has-more? ; M: sqlite-statement query-results ( query -- result-set ) -break dup statement-handle sqlite-result-set dup advance-row ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index c775bac3ab..6c0a580980 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -22,12 +22,6 @@ IN: db.tuples class db-columns find-primary-key sql-spec-slot-name ] keep set-slot-named ; -! : primary-key-spec ( class -- spec ) -! db-columns [ primary-key? ] find nip ; -! -! : primary-key ( tuple -- obj ) -! dup class primary-key-spec first swap get-slot-named ; - ! returns a sequence of prepared-statements HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) @@ -81,6 +75,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) + break dup class db-columns find-primary-key assigned-id? [ insert-assigned ] [ diff --git a/extra/semantic-db/db/db.factor b/extra/semantic-db/db/db.factor index df8c5b4a8a..52271bfda8 100644 --- a/extra/semantic-db/db/db.factor +++ b/extra/semantic-db/db/db.factor @@ -35,7 +35,7 @@ M: sequence bindings : 1result ( array -- result ) #! return the first (and hopefully only) element of the array, or f - dup length 0 > [ first ] [ drop f ] if ; + dup length zero? [ drop f ] [ first ] if ; : (collect-int-columns) ( statement n -- ) [ dupd column-int , ] each drop ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 0096b89d34..1ac4a76d3a 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,7 +1,9 @@ -USING: accessors db db.sqlite db.tuples kernel semantic-db tools.test ; +USING: accessors db db.sqlite db.tuples kernel math semantic-db semantic-db.type tools.test ; IN: temporary [ +USE: tools.walker +break create-node-table create-arc-table [ 1 ] [ "first node" create-node ] unit-test [ 2 ] [ "second node" create-node ] unit-test @@ -9,3 +11,9 @@ IN: temporary [ 4 ] [ f create-node ] unit-test [ 5 ] [ 1 2 3 create-arc ] unit-test ] with-tmp-sqlite + +[ + init-semantic-db + [ t ] [ "content" ensure-type "this is some content" ensure-node-of-type integer? ] unit-test + [ t ] [ "content" select-node-of-type integer? ] +] with-tmp-sqlite diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index bd29dba5f8..f6a6983ae4 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 db db.tuples db.types db.sqlite kernel new-slots sequences ; +USING: accessors arrays db db.tuples db.types db.sqlite kernel math new-slots sequences ; IN: semantic-db ! new semantic-db using Doug Coleman's new db abstraction library @@ -11,7 +11,7 @@ TUPLE: node id content ; node "node" { - { "id" "id" SERIAL +native-id+ +autoincrement+ } + { "id" "id" +native-id+ +autoincrement+ } { "content" "content" TEXT } } define-persistent @@ -19,7 +19,7 @@ node "node" node create-table ; : create-node ( content -- id ) - dup persist id>> ; + dup insert-tuple id>> ; TUPLE: arc relation subject object ; @@ -30,10 +30,10 @@ TUPLE: arc relation subject object ; arc "arc" { - { "id" "id" SERIAL +native-id+ } ! foreign key to node table? - { "relation" "relation" SERIAL +not-null+ } - { "subject" "subject" SERIAL +not-null+ } - { "object" "object" SERIAL +not-null+ } + { "id" "id" INTEGER } ! foreign key to node table? + { "relation" "relation" INTEGER +not-null+ } + { "subject" "subject" INTEGER +not-null+ } + { "object" "object" INTEGER +not-null+ } } define-persistent : create-arc-table ( -- ) @@ -41,34 +41,48 @@ arc "arc" : insert-arc ( arc -- ) dup delegate insert-tuple - [ ] [ insert-sql ] make-tuple-statement insert-statement drop ; + insert-tuple ; + ! [ ] [ insert-sql ] make-tuple-statement insert-statement drop ; -: persist-arc ( arc -- ) - dup primary-key [ update-tuple ] [ insert-arc ] if ; +! : insert-arc ( arc -- ) +! dup primary-key [ update-tuple ] [ insert-arc ] if ; : delete-arc ( arc -- ) dup delete-tuple delegate delete-tuple ; : create-arc ( relation subject object -- id ) - dup persist-arc id>> ; + dup insert-arc id>> ; : create-bootstrap-nodes ( -- ) - { "context" "relation" "is of type" "semantic-db" "is in context" } + { "context" "type" "relation" "is of type" "semantic-db" "is in context" } [ create-node drop ] each ; +! TODO: maybe put these in a 'special nodes' table : context-type 1 ; inline -: relation-type 2 ; inline -: has-type-relation 3 ; inline -: semantic-db-context 4 ; inline -: has-context-relation 5 ; inline +: type-type 2 ; inline +: relation-type 3 ; inline +: has-type-relation 4 ; inline +: semantic-db-context 5 ; inline +: has-context-relation 6 ; inline : create-bootstrap-arcs ( -- ) + ! give everything a type + has-type-relation context-type type-type create-arc drop + has-type-relation type-type type-type create-arc drop + has-type-relation relation-type type-type create-arc drop has-type-relation has-type-relation relation-type create-arc drop has-type-relation semantic-db-context context-type create-arc drop - has-context-relation has-type-relation semantic-db-context create-arc drop has-type-relation has-context-relation relation-type create-arc drop + ! give relations a context (semantic-db context) + has-context-relation has-type-relation semantic-db-context create-arc drop has-context-relation has-context-relation semantic-db-context create-arc drop ; : init-semantic-db ( -- ) create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; +: 1result ( array -- result ) + #! return the first (and hopefully only) element of the array, or f + dup length zero? [ drop f ] [ first ] if ; + +: param ( value key type -- param ) + rot 3array ; diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor index be4da4da83..32c93fdb80 100644 --- a/extra/semantic-db/type/type.factor +++ b/extra/semantic-db/type/type.factor @@ -1,19 +1,42 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel semantic-db ; +USING: arrays db db.types kernel semantic-db ; IN: semantic-db.type : assign-type ( type nid -- arc-id ) has-type-relation spin create-arc ; -: create-node-of-type ( type name -- node-id ) +: create-node-of-type ( type content -- node-id ) create-node [ assign-type drop ] keep ; -: select-node-of-type ( type name -- node-id? ) - ! find a node with the given name, that is the subject of an arc with: +: select-nodes-of-type ( type -- node-ids ) + "type" INTEGER param + has-type-relation "has_type" INTEGER param 2array + "select a.subject from arc a where a.relation = :has_type and a.object = :type" + do-bound-query ; + +: select-node-of-type ( type -- node-id ) + select-nodes-of-type 1array ; + +: select-nodes-of-type-with-content ( type content -- node-ids ) + ! find nodes with the given content that are the subjects of arcs with: ! relation = has-type-relation ! object = type - ; + "name" TEXT param + swap "type" INTEGER param + has-type-relation "has_type" INTEGER param 3array + "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type" + do-bound-query ; -: ensure-node-of-type ( type name -- node-id ) +: select-node-of-type-with-content ( type content -- node-id/f ) + select-nodes-of-type-with-content 1result ; + +: ensure-node-of-type ( type content -- node-id ) 2dup select-node-of-type [ 2nip ] [ create-node-of-type ] if* ; + +: ensure-type ( type -- node-id ) + dup "type" = [ + drop type-type + ] [ + type-type swap ensure-node-of-type + ] if ; From 89b669a0588b3e2dc5c319a09310894b904cba0e Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 4 Mar 2008 11:16:06 +1100 Subject: [PATCH 21/63] html.elements: add the media element property --- extra/html/elements/elements.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 4f9a052032..286037d4dc 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -161,5 +161,6 @@ SYMBOL: html "id" "onclick" "style" "valign" "accesskey" "src" "language" "colspan" "onchange" "rel" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" + "media" ] [ define-attribute-word ] each ] with-compilation-unit From 4f815ccc036be255bfd17138e63053d3ffd3a271 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 4 Mar 2008 12:16:46 +1100 Subject: [PATCH 22/63] tetris: use alarms instead of old timers library --- extra/tetris/tetris.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index 78f3f8f0f7..02f8f240d2 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ui.gadgets ui.gadgets.labels ui.gadgets.worlds -ui.gadgets.status-bar ui.gestures ui.render ui tetris.game -tetris.gl sequences arrays math math.parser namespaces timers ; +USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels +ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui +tetris.game tetris.gl sequences system math math.parser namespaces ; IN: tetris -TUPLE: tetris-gadget tetris ; +TUPLE: tetris-gadget tetris alarm ; : ( tetris -- gadget ) tetris-gadget construct-gadget @@ -41,14 +41,15 @@ tetris-gadget H{ { T{ key-down f f "n" } [ new-tetris ] } } set-gestures -M: tetris-gadget tick ( object -- ) +: tick ( gadget -- ) dup tetris-gadget-tetris maybe-update relayout-1 ; M: tetris-gadget graft* ( gadget -- ) - 100 1 add-timer ; + dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm + swap set-tetris-gadget-alarm ; M: tetris-gadget ungraft* ( gadget -- ) - remove-timer ; + [ tetris-gadget-alarm cancel-alarm f ] keep set-tetris-gadget-alarm ; : tetris-window ( -- ) [ From ebd6715ecf003ca577939f746682227e1f8101d0 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 4 Mar 2008 12:23:36 +1100 Subject: [PATCH 23/63] jamshred: updated to use alarms instead of timers --- extra/jamshred/jamshred.factor | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 890a0fe1ec..8beecc955c 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays jamshred.game jamshred.gl kernel math math.constants -namespaces sequences timers ui ui.gadgets ui.gestures ui.render +USING: alarms arrays calendar jamshred.game jamshred.gl kernel math +math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render math.vectors ; IN: jamshred -TUPLE: jamshred-gadget jamshred last-hand-loc ; +TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; : ( jamshred -- gadget ) jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ; @@ -19,13 +19,17 @@ M: jamshred-gadget pref-dim* M: jamshred-gadget draw-gadget* ( gadget -- ) dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ; -M: jamshred-gadget tick ( gadget -- ) +: tick ( gadget -- ) dup jamshred-gadget-jamshred jamshred-update relayout-1 ; M: jamshred-gadget graft* ( gadget -- ) - 10 1 add-timer ; + [ + [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm + ] keep set-jamshred-gadget-alarm ; -M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ; +M: jamshred-gadget ungraft* ( gadget -- ) + [ jamshred-gadget-alarm cancel-alarm f ] keep + set-jamshred-gadget-alarm ; : jamshred-restart ( jamshred-gadget -- ) swap set-jamshred-gadget-jamshred ; From 0c88cd14c05c58fc0432c83a98447c42b66a7dab Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 4 Mar 2008 12:38:43 +1100 Subject: [PATCH 24/63] deleting crappy files --- .../authors.txt~d77c84be199fac59cc741d5ddb7939b8f7189788 | 1 - .../authors.txt~def53a07d8ab0882e91dddb7ebd4615249ae7737 | 1 - extra/jamshred/authors.txt~master | 1 - 3 files changed, 3 deletions(-) delete mode 100755 extra/jamshred/authors.txt~d77c84be199fac59cc741d5ddb7939b8f7189788 delete mode 100755 extra/jamshred/authors.txt~def53a07d8ab0882e91dddb7ebd4615249ae7737 delete mode 100755 extra/jamshred/authors.txt~master diff --git a/extra/jamshred/authors.txt~d77c84be199fac59cc741d5ddb7939b8f7189788 b/extra/jamshred/authors.txt~d77c84be199fac59cc741d5ddb7939b8f7189788 deleted file mode 100755 index e9c193bac7..0000000000 --- a/extra/jamshred/authors.txt~d77c84be199fac59cc741d5ddb7939b8f7189788 +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/jamshred/authors.txt~def53a07d8ab0882e91dddb7ebd4615249ae7737 b/extra/jamshred/authors.txt~def53a07d8ab0882e91dddb7ebd4615249ae7737 deleted file mode 100755 index e9c193bac7..0000000000 --- a/extra/jamshred/authors.txt~def53a07d8ab0882e91dddb7ebd4615249ae7737 +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/jamshred/authors.txt~master b/extra/jamshred/authors.txt~master deleted file mode 100755 index e9c193bac7..0000000000 --- a/extra/jamshred/authors.txt~master +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman From bc1be9fcb9c3288a1fd02daff6d57a7566e71353 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 4 Mar 2008 12:47:29 +1100 Subject: [PATCH 25/63] morse: fixing endless loop in loading morse-docs --- extra/morse/morse-docs.factor | 4 +++- extra/morse/morse.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index 60befeb2af..af06ce466b 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax morse ; +USING: help.markup help.syntax ; +IN: morse HELP: ch>morse { $values @@ -11,3 +12,4 @@ HELP: morse>ch { $values { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } } { $description "If the given string represents a morse code character, then return that character, otherwise return f" } ; + diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index fdb4bf7c4e..cea16c0ee0 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,7 +1,7 @@ ! 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 ; +parser-combinators promises sequences strings unicode.case ; IN: morse Date: Thu, 6 Mar 2008 12:37:51 +1100 Subject: [PATCH 26/63] experimental semantic-db before a major change --- extra/semantic-db/context/context.factor | 17 ++++-- extra/semantic-db/hierarchy/hierarchy.factor | 25 +++++--- extra/semantic-db/relations/relations.factor | 27 +++++++++ extra/semantic-db/semantic-db-tests.factor | 17 ++++-- extra/semantic-db/semantic-db.factor | 63 +++++++++++--------- extra/semantic-db/type/type.factor | 26 ++++---- 6 files changed, 118 insertions(+), 57 deletions(-) create mode 100644 extra/semantic-db/relations/relations.factor diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor index e103fbc92e..94ee000bcc 100644 --- a/extra/semantic-db/context/context.factor +++ b/extra/semantic-db/context/context.factor @@ -3,12 +3,17 @@ USING: kernel semantic-db semantic-db.type ; IN: semantic-db.context -! : all-contexts ( -- contexts ) -! has-type-relation context-type relation-object-subjects ; -! -! : context-relations ( context -- relations ) -! has-context-relation swap relation-object-subjects ; +! contexts: +! - have type 'context' in context 'semantic-db' -: ensure-context ( name -- context-id ) +: current-context ( -- context-id ) + \ current-context get ; + +: set-current-context ( context-id -- ) + \ current-context set ; + +: context-id ( name -- context-id ) context-type swap ensure-node-of-type ; +: with-context ( name quot -- ) + swap context-id [ set-current-context ] curry swap compose with-scope ; diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index 4feb3d8d6d..b764b23a7c 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,19 +1,27 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel new-slots semantic-db semantic-db.context sequences ; +USING: accessors kernel new-slots semantic-db semantic-db.relations sequences ; IN: semantic-db.hierarchy TUPLE: tree id children ; C: tree +! TODO: don't use context here. Hierarchies should be created within +! arbitrary contexts. : hierarchy-context ( -- context-id ) - "hierarchy" ensure-context ; + "hierarchy" context-id ; : has-parent-relation ( -- relation-id ) - ! find an arc with: - ! type = relation (in semantic-db context) - ! context = hierarchy - ! name = "has parent" + hierarchy-context "has parent" relation-id ; + +: parent-of ( parent child -- arc-id ) + has-parent-relation spin create-arc ; + +: select-parents ( child -- parents ) + + +: ensure-parent ( child parent -- ) + ! TODO ; : find-children ( node-id -- children ) @@ -21,7 +29,10 @@ C: tree ! relation = has-parent-relation ! object = node-id ! then load the subjects either as nodes or subtrees - ; + ":node_id" INTEGER param + has-parent-relation ":has_parent" INTEGER param 2array + "select a.subject from arc a where relation = :has_parent and object = :node_id" + single-int-results ; : get-node-hierarchy ( node-id -- tree ) dup find-children ; diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor new file mode 100644 index 0000000000..65f246b80f --- /dev/null +++ b/extra/semantic-db/relations/relations.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: kernel semantic-db semantic-db.context semantic-db.type ; +IN: semantic-db.relations + +! relations: +! - have type 'relation' in context 'semantic-db' +! - have a context in context 'semantic-db' + +: create-relation ( context-id relation-name -- relation-id ) + relation-type swap ensure-node-of-type + tuck has-context-relation spin create-arc ; + +: select-relation ( context-id relation-name -- relation-id/f ) + [ + ":name" TEXT param , + has-type-relation ":has_type" INTEGER param , + relation-type ":relation_type" INTEGER param , + ":context" INTEGER param , + has-context-relation ":has_context" INTEGER param , + ] { } make + "select n.id from node n, arc a, arc b where n.content = :name and n.id = a.subject and a.relation = :has_type and a.object = :relation_type and n.id = b.subject and b.relation = :has_context and b.object = :context" + single-int-results ; + +: relation-id ( context-id relation-name -- relation-id ) + [ select-relation ] [ create-relation ] ensure2 ; + ! 2dup select-relation [ 2nip ] [ create-relation ] if* ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 1ac4a76d3a..3aa9f2c2c7 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,9 +1,7 @@ -USING: accessors db db.sqlite db.tuples kernel math semantic-db semantic-db.type tools.test ; +USING: accessors arrays db db.sqlite db.tuples kernel math semantic-db semantic-db.type sequences tools.test tools.walker ; IN: temporary [ -USE: tools.walker -break create-node-table create-arc-table [ 1 ] [ "first node" create-node ] unit-test [ 2 ] [ "second node" create-node ] unit-test @@ -14,6 +12,15 @@ break [ init-semantic-db - [ t ] [ "content" ensure-type "this is some content" ensure-node-of-type integer? ] unit-test - [ t ] [ "content" select-node-of-type integer? ] + 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-tmp-sqlite diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index f6a6983ae4..724eb3a58d 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,10 +1,8 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays db db.tuples db.types db.sqlite kernel math new-slots sequences ; +USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ; IN: semantic-db -! new semantic-db using Doug Coleman's new db abstraction library - TUPLE: node id content ; : ( content -- node ) node construct-empty swap >>content ; @@ -21,16 +19,14 @@ node "node" : create-node ( content -- id ) dup insert-tuple id>> ; -TUPLE: arc relation subject object ; +TUPLE: arc id relation subject object ; : ( relation subject object -- arc ) - arc construct-empty - f over set-delegate - swap >>object swap >>subject swap >>relation ; + arc construct-empty swap >>object swap >>subject swap >>relation ; arc "arc" { - { "id" "id" INTEGER } ! foreign key to node table? + { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? { "relation" "relation" INTEGER +not-null+ } { "subject" "subject" INTEGER +not-null+ } { "object" "object" INTEGER +not-null+ } @@ -40,12 +36,7 @@ arc "arc" arc create-table ; : insert-arc ( arc -- ) - dup delegate insert-tuple - insert-tuple ; - ! [ ] [ insert-sql ] make-tuple-statement insert-statement drop ; - -! : insert-arc ( arc -- ) -! dup primary-key [ update-tuple ] [ insert-arc ] if ; + f dup insert-tuple id>> >>id insert-tuple ; : delete-arc ( arc -- ) dup delete-tuple delegate delete-tuple ; @@ -54,7 +45,7 @@ arc "arc" dup insert-arc id>> ; : create-bootstrap-nodes ( -- ) - { "context" "type" "relation" "is of type" "semantic-db" "is in context" } + { "context" "type" "relation" "has type" "semantic-db" "has context" } [ create-node drop ] each ; ! TODO: maybe put these in a 'special nodes' table @@ -65,24 +56,38 @@ arc "arc" : semantic-db-context 5 ; inline : has-context-relation 6 ; inline +: has-semantic-db-context ( id -- ) + has-context-relation swap semantic-db-context create-arc drop ; + +: has-type-in-semantic-db ( subject type -- ) + has-type-relation -rot create-arc drop ; + : create-bootstrap-arcs ( -- ) ! give everything a type - has-type-relation context-type type-type create-arc drop - has-type-relation type-type type-type create-arc drop - has-type-relation relation-type type-type create-arc drop - has-type-relation has-type-relation relation-type create-arc drop - has-type-relation semantic-db-context context-type create-arc drop - has-type-relation has-context-relation relation-type create-arc drop - ! give relations a context (semantic-db context) - has-context-relation has-type-relation semantic-db-context create-arc drop - has-context-relation has-context-relation semantic-db-context create-arc drop ; + context-type type-type has-type-in-semantic-db + type-type type-type has-type-in-semantic-db + relation-type type-type has-type-in-semantic-db + has-type-relation relation-type has-type-in-semantic-db + semantic-db-context context-type has-type-in-semantic-db + has-context-relation relation-type has-type-in-semantic-db + ! give relations and types the semantic-db context + context-type has-semantic-db-context + type-type has-semantic-db-context + relation-type has-semantic-db-context + has-type-relation has-semantic-db-context + has-context-relation has-semantic-db-context ; : init-semantic-db ( -- ) create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; -: 1result ( array -- result ) - #! return the first (and hopefully only) element of the array, or f - dup length zero? [ drop f ] [ first ] if ; - : param ( value key type -- param ) - rot 3array ; + swapd 3array ; + +: single-int-results ( bindings sql -- array ) + f f [ do-bound-query ] with-disposal + [ 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* ; diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor index 32c93fdb80..f2691103e7 100644 --- a/extra/semantic-db/type/type.factor +++ b/extra/semantic-db/type/type.factor @@ -1,8 +1,12 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays db db.types kernel semantic-db ; +USING: arrays db db.types kernel semantic-db sequences sequences.lib ; IN: semantic-db.type +! types: +! - have type 'type' in context 'semantic-db' +! - have a context in context 'semantic-db' + : assign-type ( type nid -- arc-id ) has-type-relation spin create-arc ; @@ -10,29 +14,31 @@ IN: semantic-db.type create-node [ assign-type drop ] keep ; : select-nodes-of-type ( type -- node-ids ) - "type" INTEGER param - has-type-relation "has_type" INTEGER param 2array + ":type" INTEGER param + has-type-relation ":has_type" INTEGER param 2array "select a.subject from arc a where a.relation = :has_type and a.object = :type" - do-bound-query ; + single-int-results ; : select-node-of-type ( type -- node-id ) - select-nodes-of-type 1array ; + select-nodes-of-type ?first ; : select-nodes-of-type-with-content ( type content -- node-ids ) ! find nodes with the given content that are the subjects of arcs with: ! relation = has-type-relation ! object = type - "name" TEXT param - swap "type" INTEGER param - has-type-relation "has_type" INTEGER param 3array + ":name" TEXT param + swap ":type" INTEGER param + has-type-relation ":has_type" INTEGER param 3array "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type" - do-bound-query ; + single-int-results ; : select-node-of-type-with-content ( type content -- node-id/f ) select-nodes-of-type-with-content 1result ; : ensure-node-of-type ( type content -- node-id ) - 2dup select-node-of-type [ 2nip ] [ create-node-of-type ] if* ; + [ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ; + ! 2dup select-node-of-type-with-content [ 2nip ] [ create-node-of-type ] if* ; + : ensure-type ( type -- node-id ) dup "type" = [ From 0c2ceed71b356d93c8bb8933684e54c611f0b810 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 6 Mar 2008 12:38:28 +1100 Subject: [PATCH 27/63] db: get rid of a hack no longer needed for semantic-db --- extra/db/tuples/tuples.factor | 2 +- extra/db/types/types.factor | 26 ++------------------------ 2 files changed, 3 insertions(+), 25 deletions(-) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index a52c19288b..ea97eee1c9 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -87,7 +87,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - break + ! break dup class db-columns find-primary-key assigned-id? [ insert-assigned ] [ diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index a9b60b41fb..c84b23c50f 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -195,33 +195,11 @@ TUPLE: no-slot-named ; : offset-of-slot ( str obj -- n ) class slot-spec-named slot-spec-offset ; -DEFER: get-slot-named -: get-delegate-slot-named ( str obj -- value ) - delegate [ get-slot-named ] [ drop no-slot-named ] if* ; - -! : get-slot-named ( str obj -- value ) -! tuck offset-of-slot [ no-slot-named ] unless* slot ; - : get-slot-named ( str obj -- value ) - 2dup offset-of-slot [ - rot drop slot - ] [ - get-delegate-slot-named - ] if* ; - -DEFER: set-slot-named -: set-delegate-slot-named ( value str obj -- ) - delegate [ set-slot-named ] [ 2drop no-slot-named ] if* ; - -! : set-slot-named ( value str obj -- ) -! tuck offset-of-slot [ no-slot-named ] unless* set-slot ; + tuck offset-of-slot [ no-slot-named ] unless* slot ; : set-slot-named ( value str obj -- ) - 2dup offset-of-slot [ - rot drop set-slot - ] [ - set-delegate-slot-named - ] if* ; + tuck offset-of-slot [ no-slot-named ] unless* set-slot ; : tuple>filled-slots ( tuple -- alist ) dup mirror-slots [ slot-spec-name ] map From 6bb2a46acb5cc4c9c3d641b761a47111b613765c Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 6 Mar 2008 23:54:16 +1100 Subject: [PATCH 28/63] semantic-db: I like the new stuff better than the old stuff --- extra/semantic-db/context/context.factor | 21 +++--- extra/semantic-db/hierarchy/hierarchy.factor | 52 +++++++------- extra/semantic-db/relations/relations.factor | 25 ++++--- extra/semantic-db/semantic-db-tests.factor | 68 ++++++++++++++----- extra/semantic-db/semantic-db.factor | 71 +++++++++----------- extra/semantic-db/type/type.factor | 6 +- 6 files changed, 136 insertions(+), 107 deletions(-) diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor index 94ee000bcc..777c481ebb 100644 --- a/extra/semantic-db/context/context.factor +++ b/extra/semantic-db/context/context.factor @@ -1,19 +1,16 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel semantic-db semantic-db.type ; +USING: kernel namespaces semantic-db ; IN: semantic-db.context -! contexts: -! - have type 'context' in context 'semantic-db' +: create-context* ( context-name -- context-id ) create-node* ; +: create-context ( context-name -- ) create-context* drop ; -: current-context ( -- context-id ) - \ current-context get ; +: context ( -- context-id ) + \ context get ; -: set-current-context ( context-id -- ) - \ current-context set ; +: set-context ( context-id -- ) + \ context set ; -: context-id ( name -- context-id ) - context-type swap ensure-node-of-type ; - -: with-context ( name quot -- ) - swap context-id [ set-current-context ] curry swap compose with-scope ; +: 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 b764b23a7c..ef7670d15c 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,38 +1,44 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel new-slots semantic-db semantic-db.relations sequences ; +USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ; IN: semantic-db.hierarchy TUPLE: tree id children ; C: tree -! TODO: don't use context here. Hierarchies should be created within -! arbitrary contexts. -: hierarchy-context ( -- context-id ) - "hierarchy" context-id ; - : has-parent-relation ( -- relation-id ) - hierarchy-context "has parent" relation-id ; + "has parent" relation-id ; -: parent-of ( parent child -- arc-id ) - has-parent-relation spin create-arc ; +: parent-child* ( parent child -- arc-id ) + has-parent-relation spin create-arc* ; -: select-parents ( child -- parents ) +: parent-child ( parent child -- ) + parent-child* drop ; +: un-parent-child ( parent child -- ) + has-parent-relation -rot select-tuples [ id>> delete-arc ] each ; -: ensure-parent ( child parent -- ) - ! TODO - ; +: child-arcs ( node-id -- child-arcs ) + has-parent-relation f rot select-tuples ; -: find-children ( node-id -- children ) - ! find arcs with: - ! relation = has-parent-relation - ! object = node-id - ! then load the subjects either as nodes or subtrees - ":node_id" INTEGER param - has-parent-relation ":has_parent" INTEGER param 2array - "select a.subject from arc a where relation = :has_parent and object = :node_id" - single-int-results ; +: children ( node-id -- children ) + child-arcs [ subject>> ] map ; + +: parent-arcs ( node-id -- parent-arcs ) + has-parent-relation swap f select-tuples ; + +: parents ( node-id -- parents ) + parent-arcs [ object>> ] map ; : get-node-hierarchy ( node-id -- tree ) - dup find-children ; + 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 ; diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor index 65f246b80f..17c335c4ae 100644 --- a/extra/semantic-db/relations/relations.factor +++ b/extra/semantic-db/relations/relations.factor @@ -1,27 +1,26 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel semantic-db semantic-db.context semantic-db.type ; +USING: db.types kernel namespaces semantic-db semantic-db.context +sequences.lib ; IN: semantic-db.relations ! relations: -! - have type 'relation' in context 'semantic-db' ! - have a context in context 'semantic-db' -: create-relation ( context-id relation-name -- relation-id ) - relation-type swap ensure-node-of-type - tuck has-context-relation spin create-arc ; +: create-relation* ( context-id relation-name -- relation-id ) + create-node* tuck has-context-relation spin create-arc ; -: select-relation ( context-id relation-name -- relation-id/f ) +: create-relation ( context-id relation-name -- ) + create-relation* drop ; + +: get-relation ( context-id relation-name -- relation-id/f ) [ ":name" TEXT param , - has-type-relation ":has_type" INTEGER param , - relation-type ":relation_type" INTEGER param , ":context" INTEGER param , has-context-relation ":has_context" INTEGER param , ] { } make - "select n.id from node n, arc a, arc b where n.content = :name and n.id = a.subject and a.relation = :has_type and a.object = :relation_type and n.id = b.subject and b.relation = :has_context and b.object = :context" - single-int-results ; + "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 ( context-id relation-name -- relation-id ) - [ select-relation ] [ create-relation ] ensure2 ; - ! 2dup select-relation [ 2nip ] [ create-relation ] if* ; +: relation-id ( relation-name -- relation-id ) + context 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 3aa9f2c2c7..4f67895a6f 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,26 +1,58 @@ -USING: accessors arrays db db.sqlite db.tuples kernel math semantic-db semantic-db.type sequences tools.test tools.walker ; -IN: temporary +USING: accessors arrays db db.sqlite db.tuples kernel math namespaces +semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations +sequences tools.test tools.walker ; +IN: vocab.tests [ 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-tmp-sqlite [ init-semantic-db - 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 + "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-tmp-sqlite + +! test hierarchy +[ + 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" } { "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 ] unit-test + [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents ] unit-test + ] with-context ] with-tmp-sqlite diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 724eb3a58d..a48048f152 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -7,6 +7,9 @@ TUPLE: node id content ; : ( content -- node ) node construct-empty swap >>content ; +: ( id -- node ) + node construct-empty swap >>id ; + node "node" { { "id" "id" +native-id+ +autoincrement+ } @@ -16,14 +19,38 @@ node "node" : create-node-table ( -- ) node create-table ; -: create-node ( content -- id ) +: delete-node ( node-id -- ) + delete-tuple ; + +: 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 ; : ( relation subject object -- arc ) arc construct-empty swap >>object swap >>subject swap >>relation ; +: ( id -- arc ) + arc construct-empty swap >>id ; + +: insert-arc ( arc -- ) + f dup insert-tuple id>> >>id insert-tuple ; + +: delete-arc ( arc-id -- ) + dup delete-node delete-tuple ; + +: create-arc* ( relation subject object -- 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? @@ -35,47 +62,15 @@ arc "arc" : create-arc-table ( -- ) arc create-table ; -: insert-arc ( arc -- ) - f dup insert-tuple id>> >>id insert-tuple ; - -: delete-arc ( arc -- ) - dup delete-tuple delegate delete-tuple ; - -: create-arc ( relation subject object -- id ) - dup insert-arc id>> ; - : create-bootstrap-nodes ( -- ) - { "context" "type" "relation" "has type" "semantic-db" "has context" } - [ create-node drop ] each ; + "semantic-db" create-node + "has context" create-node ; -! TODO: maybe put these in a 'special nodes' table -: context-type 1 ; inline -: type-type 2 ; inline -: relation-type 3 ; inline -: has-type-relation 4 ; inline -: semantic-db-context 5 ; inline -: has-context-relation 6 ; inline - -: has-semantic-db-context ( id -- ) - has-context-relation swap semantic-db-context create-arc drop ; - -: has-type-in-semantic-db ( subject type -- ) - has-type-relation -rot create-arc drop ; +: semantic-db-context 1 ; +: has-context-relation 2 ; : create-bootstrap-arcs ( -- ) - ! give everything a type - context-type type-type has-type-in-semantic-db - type-type type-type has-type-in-semantic-db - relation-type type-type has-type-in-semantic-db - has-type-relation relation-type has-type-in-semantic-db - semantic-db-context context-type has-type-in-semantic-db - has-context-relation relation-type has-type-in-semantic-db - ! give relations and types the semantic-db context - context-type has-semantic-db-context - type-type has-semantic-db-context - relation-type has-semantic-db-context - has-type-relation has-semantic-db-context - has-context-relation has-semantic-db-context ; + has-context-relation has-context-relation semantic-db-context create-arc ; : init-semantic-db ( -- ) create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor index f2691103e7..7eec2fe179 100644 --- a/extra/semantic-db/type/type.factor +++ b/extra/semantic-db/type/type.factor @@ -8,10 +8,10 @@ IN: semantic-db.type ! - have a context in context 'semantic-db' : assign-type ( type nid -- arc-id ) - has-type-relation spin create-arc ; + has-type-relation spin arc-id ; : create-node-of-type ( type content -- node-id ) - create-node [ assign-type drop ] keep ; + node-id [ assign-type drop ] keep ; : select-nodes-of-type ( type -- node-ids ) ":type" INTEGER param @@ -33,7 +33,7 @@ IN: semantic-db.type single-int-results ; : select-node-of-type-with-content ( type content -- node-id/f ) - select-nodes-of-type-with-content 1result ; + select-nodes-of-type-with-content ?first ; : ensure-node-of-type ( type content -- node-id ) [ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ; From 5aedba482ecd4050a65759068cbb2e501c0992af Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 6 Mar 2008 21:46:25 -0500 Subject: [PATCH 29/63] Fix encoding specification for Project Euler problem 22 --- extra/project-euler/022/022.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index f3a9828e01..c0a48ec055 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: ascii io.files kernel math project-euler.common sequences sequences.lib - sorting splitting ; +USING: ascii io.encodings.ascii io.files kernel math project-euler.common + sequences sequences.lib sorting splitting ; IN: project-euler.022 ! http://projecteuler.net/index.php?section=problems&id=22 @@ -29,7 +29,7 @@ IN: project-euler.022 : source-022 ( -- seq ) "extra/project-euler/022/names.txt" resource-path - file-contents [ quotable? ] subset "," split ; + ascii file-contents [ quotable? ] subset "," split ; : name-scores ( seq -- seq ) [ 1+ swap alpha-value * ] map-index ; From 1af5a9f92c5c0c47a53424f088030db21bbd3c76 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 7 Mar 2008 17:29:30 +1100 Subject: [PATCH 30/63] adding digraphs --- extra/digraphs/authors.txt | 1 + extra/digraphs/digraphs-tests.factor | 9 ++++++ extra/digraphs/digraphs.factor | 45 ++++++++++++++++++++++++++++ extra/digraphs/summary.txt | 1 + 4 files changed, 56 insertions(+) create mode 100644 extra/digraphs/authors.txt create mode 100644 extra/digraphs/digraphs-tests.factor create mode 100644 extra/digraphs/digraphs.factor create mode 100644 extra/digraphs/summary.txt diff --git a/extra/digraphs/authors.txt b/extra/digraphs/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/digraphs/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/digraphs/digraphs-tests.factor b/extra/digraphs/digraphs-tests.factor new file mode 100644 index 0000000000..b113c18ca7 --- /dev/null +++ b/extra/digraphs/digraphs-tests.factor @@ -0,0 +1,9 @@ +USING: digraphs kernel sequences tools.test ; +IN: digraphs.tests + +: test-digraph ( -- digraph ) + + { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each + { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ; + +[ 5 ] [ test-digraph topological-sort length ] unit-test diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor new file mode 100644 index 0000000000..87dc766a29 --- /dev/null +++ b/extra/digraphs/digraphs.factor @@ -0,0 +1,45 @@ +USING: accessors assocs kernel new-slots sequences vectors ; +IN: digraphs + +TUPLE: digraph ; +TUPLE: vertex value edges ; + +: ( -- digraph ) + digraph construct-empty H{ } clone over set-delegate ; + +: ( value -- vertex ) + V{ } clone vertex construct-boa ; + +: add-vertex ( key value digraph -- ) + >r swap r> set-at ; + +: children ( key digraph -- seq ) + at edges>> ; + +: @edges ( from to digraph -- to edges ) swapd at edges>> ; +: add-edge ( from to digraph -- ) @edges push ; +: delete-edge ( from to digraph -- ) @edges delete ; + +: delete-to-edges ( to digraph -- ) + [ nip dupd edges>> delete ] assoc-each drop ; + +: delete-vertex ( key digraph -- ) + 2dup delete-at delete-to-edges ; + +: unvisited? ( unvisited key -- ? ) swap key? ; +: visited ( unvisited key -- ) swap delete-at ; + +DEFER: (topological-sort) +: visit-children ( seq unvisited key -- seq unvisited ) + over children [ (topological-sort) ] each ; + +: (topological-sort) ( seq unvisited key -- seq unvisited ) + 2dup unvisited? [ + [ visit-children ] keep 2dup visited pick push + ] [ + drop + ] if ; + +: topological-sort ( digraph -- seq ) + dup clone V{ } clone spin + [ drop (topological-sort) ] assoc-each drop reverse ; diff --git a/extra/digraphs/summary.txt b/extra/digraphs/summary.txt new file mode 100644 index 0000000000..78e5a53313 --- /dev/null +++ b/extra/digraphs/summary.txt @@ -0,0 +1 @@ +Simple directed graph implementation for topological sorting From cdcc1012706dd59264b78ee279a8f8970d715759 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 8 Mar 2008 10:05:33 +1100 Subject: [PATCH 31/63] digraphs and hooks --- extra/digraphs/digraphs.factor | 5 +++++ extra/hooks/hooks-tests.factor | 14 ++++++++++++++ extra/hooks/hooks.factor | 28 ++++++++++++++++++++++++++++ 3 files changed, 47 insertions(+) create mode 100644 extra/hooks/hooks-tests.factor create mode 100644 extra/hooks/hooks.factor diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor index 87dc766a29..5c6fa9b2a1 100644 --- a/extra/digraphs/digraphs.factor +++ b/extra/digraphs/digraphs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel new-slots sequences vectors ; IN: digraphs @@ -43,3 +45,6 @@ DEFER: (topological-sort) : topological-sort ( digraph -- seq ) dup clone V{ } clone spin [ drop (topological-sort) ] assoc-each drop reverse ; + +: topological-sorted-values ( digraph -- seq ) + dup topological-sort swap [ at value>> ] curry map ; diff --git a/extra/hooks/hooks-tests.factor b/extra/hooks/hooks-tests.factor new file mode 100644 index 0000000000..683109f795 --- /dev/null +++ b/extra/hooks/hooks-tests.factor @@ -0,0 +1,14 @@ +USING: hooks kernel tools.test ; +IN: hooks.tests + +SYMBOL: test-hook +test-hook reset-hook +: add-test-hook test-hook add-hook ; +[ ] [ test-hook call-hook ] unit-test +[ "op called" ] [ "op" [ "op called" ] add-test-hook test-hook call-hook ] unit-test +[ "first called" "second called" ] [ + test-hook reset-hook + "second op" [ "second called" ] add-test-hook + "first op" [ "first called" ] add-test-hook + test-hook call-hook +] unit-test diff --git a/extra/hooks/hooks.factor b/extra/hooks/hooks.factor new file mode 100644 index 0000000000..65e310f268 --- /dev/null +++ b/extra/hooks/hooks.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: assocs digraphs kernel namespaces sequences ; +IN: hooks + +: hooks ( -- hooks ) + \ hooks global [ drop H{ } clone ] cache ; + +: hook-graph ( hook -- graph ) + hooks [ drop ] cache ; + +: reset-hook ( hook -- ) + swap hooks set-at ; + +: add-hook ( key quot hook -- ) + #! hook should be a symbol. Note that symbols with the same name but + #! different vocab are not equal + hook-graph add-vertex ; + +: before ( key1 key2 hook -- ) + hook-graph add-edge ; + +: after ( key1 key2 hook -- ) + swapd before ; + +: call-hook ( hook -- ) + hook-graph topological-sorted-values [ call ] each ; + From 229e9835fb51150542fc973a283beeded3fe4c7c Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 8 Mar 2008 10:06:56 +1100 Subject: [PATCH 32/63] deleting old semantic-db code --- extra/semantic-db/db/db-tests.factor | 26 --- extra/semantic-db/db/db.factor | 281 --------------------------- 2 files changed, 307 deletions(-) delete mode 100644 extra/semantic-db/db/db-tests.factor delete mode 100644 extra/semantic-db/db/db.factor diff --git a/extra/semantic-db/db/db-tests.factor b/extra/semantic-db/db/db-tests.factor deleted file mode 100644 index 303ec658a0..0000000000 --- a/extra/semantic-db/db/db-tests.factor +++ /dev/null @@ -1,26 +0,0 @@ -USING: io.files kernel namespaces semantic-db.db semantic-db.db.private sqlite tools.test ; -IN: temporary - -[ "n.id" ] [ "id" "n" [ 0 column-text ] field-sql ] unit-test -[ "select n.id from nodes n where n.content = :content" ] [ - - "id" "n" [ 0 column-text ] over add-field - "nodes n" over add-table - "n.content = :content" over add-condition - query-sql -] unit-test - -[ - create-node-table create-arc-table - [ 1 ] [ "first node" create-node ] unit-test - [ 2 ] [ "second node" create-node ] unit-test - [ 3 ] [ "third node" create-node ] unit-test - [ 4 ] [ f create-node ] unit-test - [ "first node" ] [ 1 node-content ] unit-test - [ 5 ] [ 1 2 3 create-arc ] unit-test - [ { { 1 2 3 } } ] [ 2 node-arcs ] unit-test - [ { { 1 2 3 } } ] [ 3 node-arcs ] unit-test - [ { { 3 1 } } ] [ 2 node-subject-arcs ] unit-test - [ { { 2 1 } } ] [ 3 node-object-arcs ] unit-test -] -with-tmp-db diff --git a/extra/semantic-db/db/db.factor b/extra/semantic-db/db/db.factor deleted file mode 100644 index 52271bfda8..0000000000 --- a/extra/semantic-db/db/db.factor +++ /dev/null @@ -1,281 +0,0 @@ -! Copyright (C) 2007, 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math namespaces new-slots sequences sqlite ; -IN: semantic-db.db - -! sqlite utils -: prepare ( string -- statement ) - db get swap sqlite-prepare ; - -: binding ( statement key val -- statement ) - >r dup integer? [ 1+ ] when dupd r> sqlite-bind-by-name-or-index ; - -GENERIC# bindings 1 ( bindings statement -- statement ) - -M: assoc bindings - swap [ binding ] assoc-each ; - -M: sequence bindings - swap dup length swap [ binding ] 2each ; - -: prepare-with-bindings ( bindings string -- statement ) - prepare bindings ; - -: select-with-bindings ( bindings string quot -- results ) - >r prepare-with-bindings dup r> sqlite-map swap sqlite-finalize ; - -: ignore-and-finalize ( statement -- ) - dup [ drop ] sqlite-each sqlite-finalize ; - -: sql-update ( string -- ) - prepare ignore-and-finalize ; - -: update-with-bindings ( bindings string -- ) - prepare-with-bindings ignore-and-finalize ; - -: 1result ( array -- result ) - #! return the first (and hopefully only) element of the array, or f - dup length zero? [ drop f ] [ first ] if ; - -: (collect-int-columns) ( statement n -- ) - [ dupd column-int , ] each drop ; - -: collect-int-columns ( statement n -- columns ) - [ (collect-int-columns) ] { } make ; - -! queries -TUPLE: field name table retriever ; -C: field - -TUPLE: query fields tables conditions args statement results ; - -: call-field-retrievers ( query - -: ( -- query ) - V{ } clone V{ } clone V{ } clone H{ } clone f f - query construct-boa ; - -: invalidate-query ( query -- query ) - f >>results ; - -: add-field ( field query -- query ) - dup invalidate-query fields>> push ; - -: add-table ( table query -- query ) - dup invalidate-query tables>> push ; - -: add-condition ( condition query -- query ) - tuck invalidate-query conditions>> push ; - -: add-arg ( arg key query -- query ) - [ invalidate-query args>> set-at ] keep ; - -> % CHAR: . , name>> % ] "" make ; - -: fields-sql ( query -- sql ) - fields>> dup length [ - [ field-sql ] map ", " join - ] [ - drop "*" - ] if ; - -: tables-sql ( query -- sql ) - tables>> ", " join ; - -: conditions-sql ( query -- sql ) - conditions>> dup length [ - " and " join "where " swap append - ] [ - drop "" - ] if ; - -: query-sql ( query -- sql ) - [ - "select" , dup fields-sql , dup "from" , tables-sql , conditions-sql , - ] { } make " " join ; - -: prepare-query ( query -- query ) - dup query-sql prepare >>statement ; - -: bind-query ( query -- query ) - dup args>> over statement>> bindings >>statement ; - -: (retrieve) ( statement query -- result ) - fields>> swap [ retriever>> call ] curry each ; - -: retrieve ( query -- query ) - dup statement>> over [ (retrieve) ] curry sqlite-map - swap >>results ; - ! dup query-statement over query-retriever sqlite-map swap >>results ; - -: finalize-query ( query -- query ) - statement>> dup sqlite-finalize f swap >>statement ; - -PRIVATE> - -: run-query ( query -- ) - dup prepare-query dup bind-query dup retrieve finalize-query ; - -: get-results ( query -- results ) - dup results>> [ nip ] [ dup run-query results>> ] if* ; - -! nodes and arcs - -! maybe merge nodes and arcs table, so arcs can be nodes too: -! create table nodes (id integer primary key autoincrement, value none, type integer, subject integer, object integer) -! nodes: -! value: node content -! type: nid of node type -! subject: null -! object: null -! -! arcs: -! value: ordinality, or null -! type: nid of relation -! subject: nid of arc subject -! object: nid of arc object -! -! An alternative layout: -! -! nodes: -! id -! type -! -! content: -! id -! content -! -! arcs: -! id -! relation -! subject -! object -! ordinal -! -! A third alternative. In this, all arcs have an entry in the nodes table, but -! their content is null. No node that isn't an arc can have null content. If an -! arc needs an ordinal, then it can be created as another arc. -! -! nodes: -! id -! content -! -! arcs: -! id -! relation -! subject -! object - -: create-node-table ( -- ) - "create table nodes (id integer primary key autoincrement, content none);" sql-update ; - -: create-arc-table ( -- ) - "create table arcs (id integer, relation integer, subject integer, object integer);" sql-update ; - -: create-node ( content -- id ) - #! if content is f then it is inserted as NULL - [ 1array ] [ drop { } clone ] if* - "insert into nodes (content) values (?);" - update-with-bindings db get sqlite-last-insert-rowid ; - -: create-bootstrap-nodes ( -- ) - { "context" "relation" "is of type" "semantic-db" "is in context" } - [ create-node drop ] each ; - -: context-type 1 ; inline -: relation-type 2 ; inline -: has-type-relation 3 ; inline -: semantic-db-context 4 ; inline -: has-context-relation 5 ; inline - -: create-arc ( relation subject object -- id ) - f create-node -roll 4array - "insert into arcs (id, relation, subject, object) values (?, ?, ?, ?);" - update-with-bindings ; - -: create-bootstrap-arcs ( -- ) - has-type-relation has-type-relation relation-type create-arc drop - has-type-relation semantic-db-context context-type create-arc drop - has-context-relation has-type-relation semantic-db-context create-arc drop - has-type-relation has-context-relation relation-type create-arc drop - has-context-relation has-context-relation semantic-db-context create-arc drop ; - -: init-semantic-db ( -- ) - create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; - -: node-content ( id -- content ) - 1array "select content from nodes where id = ?" [ 0 column-text ] select-with-bindings 1result ; - -: node-arcs ( node-id -- arcs ) - 1array "select id, relation, subject, object from arcs where subject = ?1 or object = ?1;" - [ 4 collect-int-columns ] select-with-bindings ; - -: node-subject-arcs ( node-id -- arcs ) - 1array "select object, relation from arcs where subject = ?;" - [ 2 collect-int-columns ] select-with-bindings ; - -: node-object-arcs ( node-id -- arcs ) - 1array "select subject, relation from arcs where object = ?;" - [ 2 collect-int-columns ] select-with-bindings ; - -: relation-subject-objects ( relation subject -- objects ) - 2array "select object from arcs where relation = ? and subject = ?;" - [ 0 column-int ] select-with-bindings ; - -: relation-object-subjects ( relation object -- subjects ) - 2array "select subject from arcs where relation = ? and object = ?;" - [ 0 column-int ] select-with-bindings ; - -: subject-object-relations ( subject object -- relations ) - 2array "select relation from arcs where subject = ? and object = ?" - [ 0 column-int ] select-with-bindings ; - -: type-and-name-node ( type name -- node ) - has-type-relation 3array - "select n.id from arcs a, nodes n where a.subject = n.id and a.object = ? and n.name = ? and a.relation = ?" - [ 0 column-int ] select-with-bindings 1result ; - -: create-node-of-type ( type name -- node ) - create-node [ has-type-relation -rot create-arc drop ] keep ; - -: ensure-node-of-type ( type name -- node ) - 2dup type-and-name-node [ 2nip ] [ create-node-of-type ] if* ; - -: type-and-name-in-context-node ( context type name -- node ) - - "id" "n" [ 0 column-int ] add-field - "nodes n" add-table - "n.name = :name" add-condition - ":name" add-arg - "arcs a" add-table - "a.relation = :has_type" add-condition - has-type-relation ":has_type" add-arg - "a.subject = n.id" add-condition - "a.object = :type" add-condition - ":type" add-arg - "arcs b" add-table - "b.subject = a.relation" add-condition - "b.relation = :has_context" add-condition - has-context-relation ":has_context" add-arg - "b.object = :context" add-condition - ":context" add-arg - get-results 1result ; - - -! ideas for an api: -! this would work something like jquery, where arcs can be selected according -! to parameters, and the contents of nodes and arcs are retrieved on demand, or -! at the program's convenience. It may be better to do this as a query language. -! TUPLE: node id content ; -! : node-text ( node -- text ) -! dup node-content [ -! nip -! ] [ -! node-id ! now get content from database, save it in node-content, and return it -! ] if* ; -! TUPLE: arc id relation subject object ; -! -! TUPLE: arcs ids relation subject object ; From 7ce7df5f89e543f775ab35f8c013936b8a4faa21 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 8 Mar 2008 10:07:11 +1100 Subject: [PATCH 33/63] latest semantic-db --- extra/semantic-db/hierarchy/hierarchy.factor | 2 +- extra/semantic-db/semantic-db-tests.factor | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index ef7670d15c..fa10fff01c 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -16,7 +16,7 @@ C: tree parent-child* drop ; : un-parent-child ( parent child -- ) - has-parent-relation -rot select-tuples [ id>> delete-arc ] each ; + has-parent-relation spin select-tuples [ id>> delete-arc ] each ; : child-arcs ( node-id -- child-arcs ) has-parent-relation f rot select-tuples ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 4f67895a6f..01476a145a 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,7 +1,7 @@ USING: accessors arrays db db.sqlite db.tuples kernel math namespaces semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations sequences tools.test tools.walker ; -IN: vocab.tests +IN: semantic-db.tests [ create-node-table create-arc-table @@ -48,11 +48,11 @@ IN: vocab.tests "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" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each + { { "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 ] unit-test - [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents ] unit-test + [ { "adam" "eve" } ] [ "charlie" get break get-root-nodes [ node-content ] map ] unit-test + [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test ] with-context ] with-tmp-sqlite From 50a2c511871d1c3b242f7644be7d79e2eb4f5e30 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 17:53:20 -0600 Subject: [PATCH 34/63] Fix size-of --- core/io/files/files.factor | 6 ++++++ extra/size-of/size-of.factor | 21 +++++++-------------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f740d1dc21..e3cf94f8b3 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -225,6 +225,12 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline +: set-file-lines ( seq path encoding -- ) + [ [ print ] each ] with-file-writer ; + +: set-file-contents ( str path encoding -- ) + [ write ] with-file-writer ; + : with-file-appender ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/extra/size-of/size-of.factor b/extra/size-of/size-of.factor index df43a9adb2..5b6f26acea 100644 --- a/extra/size-of/size-of.factor +++ b/extra/size-of/size-of.factor @@ -1,7 +1,9 @@ USING: kernel namespaces sequences - io io.files io.launcher bake builder.util - accessors vars ; + io io.files io.launcher io.encodings.ascii + bake builder.util + accessors vars + math.parser ; IN: size-of @@ -16,7 +18,7 @@ VAR: headers { "#include " include-headers - { "main() { printf( \"%i\\n\" , sizeof( " , " ) ) ; }" } + { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" } } bake to-strings ; @@ -26,21 +28,12 @@ VAR: headers : exe ( -- path ) "size-of" temp-file ; -: answer ( -- path ) "size-of-answer" temp-file ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : size-of ( type -- n ) - c-file - [ size-of-c-program [ print ] each ] - with-file-writer + size-of-c-program c-file ascii set-file-lines { "gcc" c-file "-o" exe } to-strings [ "Error compiling generated C program" print ] run-or-bail - - - { exe } to-strings >>arguments - answer >>stdout - >desc run-process drop - answer eval-file ; \ No newline at end of file + exe ascii contents string>number ; \ No newline at end of file From 3652a454d8f60f8b31e9b9ea871e6b2ed930bda8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 20:02:58 -0600 Subject: [PATCH 35/63] rewrite singletons to be predicate classes instead of tuples --- extra/singleton/singleton-docs.factor | 10 +++++----- extra/singleton/singleton.factor | 8 ++++---- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor index b87c557366..4ebbc9b71d 100644 --- a/extra/singleton/singleton-docs.factor +++ b/extra/singleton/singleton-docs.factor @@ -1,14 +1,14 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax kernel words ; IN: singleton HELP: SINGLETON: { $syntax "SINGLETON: class" } { $values - { "class" "a new tuple class to define" } + { "class" "a new singleton to define" } } { $description - "Defines a new tuple class with membership predicate name? and a default empty constructor that is the class name itself." + "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton." } { $examples - { $example "SINGLETON: foo\nfoo ." "T{ foo f }" } + { $example "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } } { $see-also - POSTPONE: TUPLE: + POSTPONE: PREDICATE: } ; diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index b745e8f902..f859cec5c0 100644 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel parser quotations prettyprint tuples words ; +USING: classes.predicate kernel parser quotations words ; IN: singleton + : SINGLETON: + \ word CREATE-CLASS - dup { } define-tuple-class - dup unparse create-in reset-generic - dup construct-empty 1quotation define ; parsing + dup [ eq? ] curry define-predicate-class ; parsing From 1ceeac107b8e3328472d63b3d77221d709f1d2ae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 20:05:58 -0600 Subject: [PATCH 36/63] add extra/symbols --- extra/symbols/authors.txt | 2 ++ extra/symbols/symbols-docs.factor | 9 +++++++++ extra/symbols/symbols-tests.factor | 7 +++++++ extra/symbols/symbols.factor | 8 ++++++++ 4 files changed, 26 insertions(+) create mode 100644 extra/symbols/authors.txt create mode 100644 extra/symbols/symbols-docs.factor create mode 100644 extra/symbols/symbols-tests.factor create mode 100644 extra/symbols/symbols.factor diff --git a/extra/symbols/authors.txt b/extra/symbols/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/extra/symbols/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/extra/symbols/symbols-docs.factor b/extra/symbols/symbols-docs.factor new file mode 100644 index 0000000000..c6886ce31a --- /dev/null +++ b/extra/symbols/symbols-docs.factor @@ -0,0 +1,9 @@ +USING: help.markup help.syntax ; +IN: symbols + +HELP: SYMBOLS: +{ $syntax "SYMBOLS: words... ;" } +{ $values { "words" "a sequence of new words to define" } } +{ $description "Creates a new word for every token until the ';'." } +{ $examples { $example "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } +{ $see-also POSTPONE: SYMBOL: } ; diff --git a/extra/symbols/symbols-tests.factor b/extra/symbols/symbols-tests.factor new file mode 100644 index 0000000000..84a61509c8 --- /dev/null +++ b/extra/symbols/symbols-tests.factor @@ -0,0 +1,7 @@ +USING: kernel symbols tools.test ; +IN: symbols.tests + +[ ] [ SYMBOLS: a b c ; ] unit-test +[ a ] [ a ] unit-test +[ b ] [ b ] unit-test +[ c ] [ c ] unit-test diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor new file mode 100644 index 0000000000..8e074f4163 --- /dev/null +++ b/extra/symbols/symbols.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser sequences words ; +IN: symbols + +: SYMBOLS: + ";" parse-tokens [ create-in define-symbol ] each ; + parsing From 252f55d1625e2ee4df4d65dbd86a66675a0b3764 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 20:06:23 -0600 Subject: [PATCH 37/63] add unit tests to singleton --- extra/singleton/singleton-tests.factor | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 extra/singleton/singleton-tests.factor diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor new file mode 100644 index 0000000000..1698181ed3 --- /dev/null +++ b/extra/singleton/singleton-tests.factor @@ -0,0 +1,9 @@ +USING: kernel singleton tools.test ; +IN: singleton.tests + +[ ] [ SINGLETON: bzzt ] unit-test +[ t ] [ bzzt bzzt? ] unit-test +[ t ] [ bzzt bzzt eq? ] unit-test +GENERIC: zammo ( obj -- ) +[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test +[ "yes!" ] [ bzzt zammo ] unit-test From e6d2b4bcf44cc2eea391d63afe4bb3723ee49f21 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 20:07:54 -0600 Subject: [PATCH 38/63] use symbols --- extra/koszul/koszul.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 9545e1cc9d..69de838eec 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -3,14 +3,10 @@ USING: arrays assocs hashtables assocs io kernel math math.vectors math.matrices math.matrices.elimination namespaces parser prettyprint sequences words combinators math.parser -splitting sorting shuffle ; +splitting sorting shuffle symbols ; IN: koszul ! Utilities -: SYMBOLS: - ";" parse-tokens [ create-in define-symbol ] each ; - parsing - : -1^ odd? -1 1 ? ; : >alt ( obj -- vec ) From 9701754dc4f79c00f8167333aecb812df046ae6c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 20:08:34 -0600 Subject: [PATCH 39/63] add more ,%# words to namespaces.lib (needed for db) --- extra/namespaces/lib/lib.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 8e7af02597..76ba0ac63e 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -35,6 +35,12 @@ SYMBOL: building-seq : 2, 2 n, ; : 2% 2 n% ; : 2# 2 n# ; +: 3, 3 n, ; +: 3% 3 n% ; +: 3# 3 n# ; +: 4, 4 n, ; +: 4% 4 n% ; +: 4# 4 n# ; : nmake ( quot exemplars -- seqs ) dup length dup zero? [ 1+ ] when From a8d776d2e28ff9901d0ad8f77bc193ec27d49822 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 20:10:23 -0600 Subject: [PATCH 40/63] add db.sql --- extra/db/sql/sql-tests.factor | 42 +++++++++++++++++++++ extra/db/sql/sql.factor | 70 +++++++++++++++++++++++++++++++++++ 2 files changed, 112 insertions(+) create mode 100644 extra/db/sql/sql-tests.factor create mode 100755 extra/db/sql/sql.factor diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor new file mode 100644 index 0000000000..2133b0e36c --- /dev/null +++ b/extra/db/sql/sql-tests.factor @@ -0,0 +1,42 @@ +USING: kernel db.sql ; +IN: db.sql.tests + +TUPLE: person name age ; +: insert-1 + { insert + { table "person" } + { columns "name" "age" } + { values "erg" 26 } + } ; + +: update-1 + { update "person" + { set { "name" "erg" } + { "age" 6 } } + { where { "age" 6 } } + } ; + +: select-1 + { select + { columns + "branchno" + { count "staffno" as "mycount" } + { sum "salary" as "mysum" } } + { from "staff" "lol" } + { where + { "salary" > all + { select + { columns "salary" } + { from "staff" } + { where { "branchno" "b003" } } + } + } + { "branchno" > 3 } } + { group-by "branchno" "lol2" } + { having { count "staffno" > 1 } } + { order-by "branchno" } + { offset 40 } + { limit 20 } + } ; + + diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor new file mode 100755 index 0000000000..062eab8bc8 --- /dev/null +++ b/extra/db/sql/sql.factor @@ -0,0 +1,70 @@ +USING: kernel parser quotations tuples words +namespaces.lib namespaces sequences bake arrays combinators +prettyprint strings math.parser new-slots accessors +sequences.lib math symbols ; +USE: tools.walker +IN: db.sql + +SYMBOLS: insert update delete select distinct columns from as +where group-by having order-by limit offset is-null desc all +any count avg table values ; + +: input-spec, 1, ; +: output-spec, 2, ; +: input, 3, ; +: output, 4, ; + +DEFER: sql% + +: (sql-interleave) ( seq sep -- ) + [ sql% ] curry [ sql% ] interleave ; + +: sql-interleave ( seq str sep -- ) + swap sql% (sql-interleave) ; + +: sql-function, ( seq function -- ) + sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; + +: sql-array% ( array -- ) + unclip + { + { columns [ "," (sql-interleave) ] } + { from [ "from" "," sql-interleave ] } + { where [ "where" "and" sql-interleave ] } + { group-by [ "group by" "," sql-interleave ] } + { having [ "having" "," sql-interleave ] } + { order-by [ "order by" "," sql-interleave ] } + { offset [ "offset" sql% sql% ] } + { limit [ "limit" sql% sql% ] } + { select [ "(select" sql% sql% ")" sql% ] } + { table [ sql% ] } + { set [ "set" "," sql-interleave ] } + { values [ "values(" sql% "," (sql-interleave) ")" sql% ] } + { count [ "count" sql-function, ] } + { sum [ "sum" sql-function, ] } + { avg [ "avg" sql-function, ] } + { min [ "min" sql-function, ] } + { max [ "max" sql-function, ] } + [ sql% [ sql% ] each ] + } case ; + +TUPLE: no-sql-match ; +: sql% ( obj -- ) + { + { [ dup string? ] [ " " 0% 0% ] } + { [ dup array? ] [ sql-array% ] } + { [ dup number? ] [ number>string sql% ] } + { [ dup symbol? ] [ unparse sql% ] } + { [ dup word? ] [ unparse sql% ] } + { [ t ] [ T{ no-sql-match } throw ] } + } cond ; + +: parse-sql ( obj -- sql in-spec out-spec in out ) + [ + unclip { + { insert [ "insert into" sql% ] } + { update [ "update" sql% ] } + { delete [ "delete" sql% ] } + { select [ "select" sql% ] } + } case [ sql% ] each + ] { "" { } { } { } { } } nmake ; From b204473c8f3fd101fdc9f36bca358edba7a9a12e Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 7 Mar 2008 21:38:16 -0500 Subject: [PATCH 41/63] Solution to Project Euler problem 59 --- extra/project-euler/059/059.factor | 92 ++++++++++++++++++++++++ extra/project-euler/059/cipher1.txt | 1 + extra/project-euler/project-euler.factor | 7 +- 3 files changed, 97 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/059/059.factor create mode 100644 extra/project-euler/059/cipher1.txt diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor new file mode 100644 index 0000000000..1c20d1ab34 --- /dev/null +++ b/extra/project-euler/059/059.factor @@ -0,0 +1,92 @@ +! Copyright (c) 2008 Aaron Schaefer, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math + math.parser namespaces sequences sequences.lib sequences.private sorting + splitting strings ; +IN: project-euler.059 + +! http://projecteuler.net/index.php?section=problems&id=59 + +! DESCRIPTION +! ----------- + +! Each character on a computer is assigned a unique code and the preferred +! standard is ASCII (American Standard Code for Information Interchange). For +! example, uppercase A = 65, asterisk (*) = 42, and lowercase k = 107. + +! A modern encryption method is to take a text file, convert the bytes to +! ASCII, then XOR each byte with a given value, taken from a secret key. The +! advantage with the XOR function is that using the same encryption key on the +! cipher text, restores the plain text; for example, 65 XOR 42 = 107, then 107 +! XOR 42 = 65. + +! For unbreakable encryption, the key is the same length as the plain text +! message, and the key is made up of random bytes. The user would keep the +! encrypted message and the encryption key in different locations, and without +! both "halves", it is impossible to decrypt the message. + +! Unfortunately, this method is impractical for most users, so the modified +! method is to use a password as a key. If the password is shorter than the +! message, which is likely, the key is repeated cyclically throughout the +! message. The balance for this method is using a sufficiently long password +! key for security, but short enough to be memorable. + +! Your task has been made easy, as the encryption key consists of three lower +! case characters. Using cipher1.txt (right click and 'Save Link/Target +! As...'), a file containing the encrypted ASCII codes, and the knowledge that +! the plain text must contain common English words, decrypt the message and +! find the sum of the ASCII values in the original text. + + +! SOLUTION +! -------- + +! Assume that the space character will be the most common, so XOR the input +! text with a space character then group the text into three "columns" since +! that's how long our key is. Then do frequency analysis on each column to +! find out what the most likely candidate is for the key. + +! NOTE: This technique would probably not work well in all cases, but luckily +! it did for this particular problem. + +number ] map ; + +TUPLE: rollover seq n ; + +C: rollover + +M: rollover length rollover-n ; + +M: rollover nth-unsafe rollover-seq [ length mod ] keep nth-unsafe ; + +INSTANCE: rollover immutable-sequence + +: decrypt ( seq key -- seq ) + over length swap [ bitxor ] 2map ; + +: frequency-analysis ( seq -- seq ) + dup prune [ + [ 2dup [ = ] curry count 2array , ] each + ] { } make nip ; inline + +: most-frequent ( seq -- elt ) + frequency-analysis sort-values keys peek ; + +: crack-key ( seq key-length -- key ) + [ " " decrypt ] dip group 1 head-slice* + flip [ most-frequent ] map ; + +PRIVATE> + +: euler059 ( -- answer ) + source-059 dup 3 crack-key decrypt sum ; + +! [ euler059 ] 100 ave-time +! 13 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler059 diff --git a/extra/project-euler/059/cipher1.txt b/extra/project-euler/059/cipher1.txt new file mode 100644 index 0000000000..08cee2dba4 --- /dev/null +++ b/extra/project-euler/059/cipher1.txt @@ -0,0 +1 @@ +79,59,12,2,79,35,8,28,20,2,3,68,8,9,68,45,0,12,9,67,68,4,7,5,23,27,1,21,79,85,78,79,85,71,38,10,71,27,12,2,79,6,2,8,13,9,1,13,9,8,68,19,7,1,71,56,11,21,11,68,6,3,22,2,14,0,30,79,1,31,6,23,19,10,0,73,79,44,2,79,19,6,28,68,16,6,16,15,79,35,8,11,72,71,14,10,3,79,12,2,79,19,6,28,68,32,0,0,73,79,86,71,39,1,71,24,5,20,79,13,9,79,16,15,10,68,5,10,3,14,1,10,14,1,3,71,24,13,19,7,68,32,0,0,73,79,87,71,39,1,71,12,22,2,14,16,2,11,68,2,25,1,21,22,16,15,6,10,0,79,16,15,10,22,2,79,13,20,65,68,41,0,16,15,6,10,0,79,1,31,6,23,19,28,68,19,7,5,19,79,12,2,79,0,14,11,10,64,27,68,10,14,15,2,65,68,83,79,40,14,9,1,71,6,16,20,10,8,1,79,19,6,28,68,14,1,68,15,6,9,75,79,5,9,11,68,19,7,13,20,79,8,14,9,1,71,8,13,17,10,23,71,3,13,0,7,16,71,27,11,71,10,18,2,29,29,8,1,1,73,79,81,71,59,12,2,79,8,14,8,12,19,79,23,15,6,10,2,28,68,19,7,22,8,26,3,15,79,16,15,10,68,3,14,22,12,1,1,20,28,72,71,14,10,3,79,16,15,10,68,3,14,22,12,1,1,20,28,68,4,14,10,71,1,1,17,10,22,71,10,28,19,6,10,0,26,13,20,7,68,14,27,74,71,89,68,32,0,0,71,28,1,9,27,68,45,0,12,9,79,16,15,10,68,37,14,20,19,6,23,19,79,83,71,27,11,71,27,1,11,3,68,2,25,1,21,22,11,9,10,68,6,13,11,18,27,68,19,7,1,71,3,13,0,7,16,71,28,11,71,27,12,6,27,68,2,25,1,21,22,11,9,10,68,10,6,3,15,27,68,5,10,8,14,10,18,2,79,6,2,12,5,18,28,1,71,0,2,71,7,13,20,79,16,2,28,16,14,2,11,9,22,74,71,87,68,45,0,12,9,79,12,14,2,23,2,3,2,71,24,5,20,79,10,8,27,68,19,7,1,71,3,13,0,7,16,92,79,12,2,79,19,6,28,68,8,1,8,30,79,5,71,24,13,19,1,1,20,28,68,19,0,68,19,7,1,71,3,13,0,7,16,73,79,93,71,59,12,2,79,11,9,10,68,16,7,11,71,6,23,71,27,12,2,79,16,21,26,1,71,3,13,0,7,16,75,79,19,15,0,68,0,6,18,2,28,68,11,6,3,15,27,68,19,0,68,2,25,1,21,22,11,9,10,72,71,24,5,20,79,3,8,6,10,0,79,16,8,79,7,8,2,1,71,6,10,19,0,68,19,7,1,71,24,11,21,3,0,73,79,85,87,79,38,18,27,68,6,3,16,15,0,17,0,7,68,19,7,1,71,24,11,21,3,0,71,24,5,20,79,9,6,11,1,71,27,12,21,0,17,0,7,68,15,6,9,75,79,16,15,10,68,16,0,22,11,11,68,3,6,0,9,72,16,71,29,1,4,0,3,9,6,30,2,79,12,14,2,68,16,7,1,9,79,12,2,79,7,6,2,1,73,79,85,86,79,33,17,10,10,71,6,10,71,7,13,20,79,11,16,1,68,11,14,10,3,79,5,9,11,68,6,2,11,9,8,68,15,6,23,71,0,19,9,79,20,2,0,20,11,10,72,71,7,1,71,24,5,20,79,10,8,27,68,6,12,7,2,31,16,2,11,74,71,94,86,71,45,17,19,79,16,8,79,5,11,3,68,16,7,11,71,13,1,11,6,1,17,10,0,71,7,13,10,79,5,9,11,68,6,12,7,2,31,16,2,11,68,15,6,9,75,79,12,2,79,3,6,25,1,71,27,12,2,79,22,14,8,12,19,79,16,8,79,6,2,12,11,10,10,68,4,7,13,11,11,22,2,1,68,8,9,68,32,0,0,73,79,85,84,79,48,15,10,29,71,14,22,2,79,22,2,13,11,21,1,69,71,59,12,14,28,68,14,28,68,9,0,16,71,14,68,23,7,29,20,6,7,6,3,68,5,6,22,19,7,68,21,10,23,18,3,16,14,1,3,71,9,22,8,2,68,15,26,9,6,1,68,23,14,23,20,6,11,9,79,11,21,79,20,11,14,10,75,79,16,15,6,23,71,29,1,5,6,22,19,7,68,4,0,9,2,28,68,1,29,11,10,79,35,8,11,74,86,91,68,52,0,68,19,7,1,71,56,11,21,11,68,5,10,7,6,2,1,71,7,17,10,14,10,71,14,10,3,79,8,14,25,1,3,79,12,2,29,1,71,0,10,71,10,5,21,27,12,71,14,9,8,1,3,71,26,23,73,79,44,2,79,19,6,28,68,1,26,8,11,79,11,1,79,17,9,9,5,14,3,13,9,8,68,11,0,18,2,79,5,9,11,68,1,14,13,19,7,2,18,3,10,2,28,23,73,79,37,9,11,68,16,10,68,15,14,18,2,79,23,2,10,10,71,7,13,20,79,3,11,0,22,30,67,68,19,7,1,71,8,8,8,29,29,71,0,2,71,27,12,2,79,11,9,3,29,71,60,11,9,79,11,1,79,16,15,10,68,33,14,16,15,10,22,73 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 5f5ffa959e..25ddd9a60b 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -14,9 +14,10 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.045 project-euler.046 project-euler.047 project-euler.048 - project-euler.052 project-euler.053 project-euler.056 project-euler.067 - project-euler.075 project-euler.079 project-euler.092 project-euler.097 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.052 project-euler.053 project-euler.056 project-euler.059 + project-euler.067 project-euler.075 project-euler.079 project-euler.092 + project-euler.097 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Fri, 7 Mar 2008 21:24:50 -0600 Subject: [PATCH 42/63] use SYMBOLS: in several places --- extra/crypto/md5/md5.factor | 11 ++------ extra/crypto/sha1/sha1.factor | 15 ++-------- extra/crypto/sha2/sha2.factor | 14 ++-------- extra/db/types/types.factor | 40 +++++---------------------- extra/ui/gestures/gestures.factor | 7 ++--- extra/ui/windows/windows.factor | 38 ++++++++++--------------- extra/xmode/marker/state/state.factor | 16 +++-------- 7 files changed, 33 insertions(+), 108 deletions(-) diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index debef26de4..224b203fba 100644 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -3,19 +3,12 @@ USING: kernel io io.binary io.files io.streams.string math math.functions math.parser namespaces splitting strings sequences crypto.common byte-arrays locals sequences.private -io.encodings.binary ; +io.encodings.binary symbols ; IN: crypto.md5 bignum ; foldable diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index eaad6df622..e2398311b7 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,23 +1,12 @@ USING: arrays combinators crypto.common kernel io io.encodings.binary io.files io.streams.string math.vectors strings sequences namespaces math parser sequences vectors io.binary -hashtables ; +hashtables symbols ; IN: crypto.sha1 ! Implemented according to RFC 3174. -SYMBOL: h0 -SYMBOL: h1 -SYMBOL: h2 -SYMBOL: h3 -SYMBOL: h4 -SYMBOL: A -SYMBOL: B -SYMBOL: C -SYMBOL: D -SYMBOL: E -SYMBOL: w -SYMBOL: K +SYMBOL: h0 h1 h2 h3 h4 A B C D E w K ; : get-wth ( n -- wth ) w get nth ; inline : shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor index 8e7710f40f..07d38b83bb 100644 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -1,19 +1,10 @@ USING: crypto.common kernel splitting math sequences namespaces -io.binary ; +io.binary symbols ; IN: crypto.sha2 word +SYMBOL: vars M K H S0 S1 process-M word-size block-size >word ; : a 0 ; : b 1 ; @@ -139,4 +130,3 @@ PRIVATE> : string>sha-256-string ( string -- hexstring ) string>sha-256 hex-string ; - diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 023c72cd2d..c6d11281a1 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes mirrors tuples combinators calendar.format serialize -io.streams.string ; +io.streams.string symbols ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -14,11 +14,10 @@ HOOK: create-type-table db ( -- hash ) HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; -! ID is the Primary key -! +native-id+ can be a columns type or a modifier -SYMBOL: +native-id+ -! +assigned-id+ can only be a modifier -SYMBOL: +assigned-id+ + +SYMBOLS: +native-id+ +assigned-id+ +autoincrement+ ++serial+ +unique+ +default+ +null+ +not-null+ ++foreign-id+ +has-many+ ; : (primary-key?) ( obj -- ? ) { +native-id+ +assigned-id+ } member? ; @@ -45,35 +44,10 @@ SYMBOL: +assigned-id+ : assigned-id? ( spec -- ? ) sql-spec-primary-key +assigned-id+ = ; -SYMBOL: +foreign-id+ - -! Same concept, SQLite has autoincrement, PostgreSQL has serial -SYMBOL: +autoincrement+ -SYMBOL: +serial+ -SYMBOL: +unique+ - -SYMBOL: +default+ -SYMBOL: +null+ -SYMBOL: +not-null+ - -SYMBOL: +has-many+ - : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -SYMBOL: INTEGER -SYMBOL: BIG-INTEGER -SYMBOL: DOUBLE -SYMBOL: REAL -SYMBOL: BOOLEAN -SYMBOL: TEXT -SYMBOL: VARCHAR -SYMBOL: DATE -SYMBOL: TIME -SYMBOL: DATETIME -SYMBOL: TIMESTAMP -SYMBOL: BLOB -SYMBOL: FACTOR-BLOB -SYMBOL: NULL +SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR +DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; : spec>tuple ( class spec -- tuple ) [ ?first3 ] keep 3 ?tail* diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 0edf82dbd1..e494afd46d 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -3,7 +3,7 @@ USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser math.vectors tuples classes ui.gadgets combinators.lib boxes -calendar alarms ; +calendar alarms symbols ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; @@ -49,10 +49,7 @@ TUPLE: select-all-action ; C: select-all-action tuple>array 1 head* >tuple ; ! Modifiers -SYMBOL: C+ -SYMBOL: A+ -SYMBOL: M+ -SYMBOL: S+ +SYMBOLS: C+ A+ M+ S+ ; TUPLE: key-down mods sym ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 6cba5cfdf8..a1b513380c 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -6,7 +6,8 @@ math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line -shuffle opengl ui.render unicode.case ascii math.bitfields ; +shuffle opengl ui.render unicode.case ascii math.bitfields +locals symbols ; IN: ui.windows TUPLE: windows-ui-backend ; @@ -67,9 +68,7 @@ M: pasteboard set-clipboard-contents drop copy ; TUPLE: win hWnd hDC hRC world title ; C: win -SYMBOL: msg-obj -SYMBOL: class-name-ptr -SYMBOL: mouse-captured +SYMBOLS: msg-obj class-name-ptr mouse-captured ; : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline @@ -188,30 +187,21 @@ SYMBOL: mouse-captured ] if ] if ; -SYMBOL: lParam -SYMBOL: wParam -SYMBOL: uMsg -SYMBOL: hWnd - -: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) - lParam set wParam set uMsg set hWnd set - wParam get exclude-key-wm-keydown? [ - wParam get keystroke>gesture - hWnd get window-focus send-gesture drop +:: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) + wParam exclude-key-wm-keydown? [ + wParam keystroke>gesture + hWnd window-focus send-gesture drop ] unless ; -: handle-wm-char ( hWnd uMsg wParam lParam -- ) - lParam set wParam set uMsg set hWnd set - wParam get exclude-key-wm-char? ctrl? alt? xor or [ - wParam get 1string - hWnd get window-focus user-input +:: handle-wm-char ( hWnd uMsg wParam lParam -- ) + wParam exclude-key-wm-char? ctrl? alt? xor or [ + wParam 1string + hWnd window-focus user-input ] unless ; -: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) - lParam set wParam set uMsg set hWnd set - wParam get keystroke>gesture - hWnd get window-focus send-gesture - drop ; +:: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) + wParam keystroke>gesture + hWnd window-focus send-gesture drop ; : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n ) dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ; diff --git a/extra/xmode/marker/state/state.factor b/extra/xmode/marker/state/state.factor index e3e380798f..2cf12f301d 100755 --- a/extra/xmode/marker/state/state.factor +++ b/extra/xmode/marker/state/state.factor @@ -1,20 +1,12 @@ -USING: xmode.marker.context xmode.rules +USING: xmode.marker.context xmode.rules symbols xmode.tokens namespaces kernel sequences assocs math ; IN: xmode.marker.state ! Based on org.gjt.sp.jedit.syntax.TokenMarker -SYMBOL: line -SYMBOL: last-offset -SYMBOL: position -SYMBOL: context - -SYMBOL: whitespace-end -SYMBOL: seen-whitespace-end? - -SYMBOL: escaped? -SYMBOL: process-escape? -SYMBOL: delegate-end-escaped? +SYMBOLS: line last-offset position context + whitespace-end seen-whitespace-end? + escaped? process-escape? delegate-end-escaped? ; : current-rule ( -- rule ) context get line-context-in-rule ; From 9eff8354c32e1ee97a99de25a5adbd1dc5174b85 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 21:25:26 -0600 Subject: [PATCH 43/63] use SYMBOLS: --- extra/io/windows/files/files.factor | 20 +++++--------------- 1 file changed, 5 insertions(+), 15 deletions(-) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index d107f80723..3d51e65116 100644 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,23 +3,13 @@ USING: alien.c-types io.files io.windows kernel math windows windows.kernel32 combinators.cleave windows.time calendar combinators math.functions -sequences combinators.lib namespaces words ; +sequences combinators.lib namespaces words symbols ; IN: io.windows.files -SYMBOL: +read-only+ -SYMBOL: +hidden+ -SYMBOL: +system+ -SYMBOL: +directory+ -SYMBOL: +archive+ -SYMBOL: +device+ -SYMBOL: +normal+ -SYMBOL: +temporary+ -SYMBOL: +sparse-file+ -SYMBOL: +reparse-point+ -SYMBOL: +compressed+ -SYMBOL: +offline+ -SYMBOL: +not-content-indexed+ -SYMBOL: +encrypted+ +SYMBOLS: +read-only+ +hidden+ +system+ ++directory+ +archive+ +device+ +normal+ +temporary+ ++sparse-file+ +reparse-point+ +compressed+ +offline+ ++not-content-indexed+ +encrypted+ ; : expand-constants ( word/obj -- obj'/obj ) dup word? [ execute ] when ; From 2fa5f34a71dab2a122bc84a0323423c4bc72ab9e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 21:26:35 -0600 Subject: [PATCH 44/63] Byte-array-ification --- core/alien/c-types/c-types-docs.factor | 24 +----------------------- core/alien/c-types/c-types.factor | 13 +------------ core/io/binary/binary-tests.factor | 4 ++-- core/io/files/files-tests.factor | 12 ++++++------ core/io/files/files.factor | 10 +++++----- core/io/streams/c/c-tests.factor | 4 +--- extra/io/buffers/buffers.factor | 22 +++++++++++----------- extra/io/mmap/mmap-tests.factor | 2 +- extra/io/unix/files/files.factor | 2 +- 9 files changed, 29 insertions(+), 64 deletions(-) diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index f4aa297a3a..1fd8cafdcf 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -88,29 +88,11 @@ HELP: memory>byte-array ( base len -- string ) { $values { "base" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; -HELP: memory>char-string ( base len -- string ) -{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } } -{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new string." } ; - -HELP: memory>u16-string ( base len -- string ) -{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } } -{ $description "Reads " { $snippet "len" } " UCS2 characters starting from " { $snippet "base" } " and stores them in a new string." } ; - HELP: byte-array>memory ( string base -- ) { $values { "byte-array" byte-array } { "base" c-ptr } } { $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." } { $warning "This word is unsafe. Improper use can corrupt memory." } ; -HELP: string>char-memory ( string base -- ) -{ $values { "string" string } { "base" c-ptr } } -{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." } -{ $warning "This word is unsafe. Improper use can corrupt memory." } ; - -HELP: string>u16-memory ( string base -- ) -{ $values { "string" string } { "base" c-ptr } } -{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." } -{ $warning "This word is unsafe. Improper use can corrupt memory." } ; - HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." } @@ -293,11 +275,7 @@ ARTICLE: "c-strings" "C strings" $nl "Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:" { $subsection alien>char-string } -{ $subsection alien>u16-string } -{ $subsection memory>char-string } -{ $subsection memory>u16-string } -{ $subsection string>char-memory } -{ $subsection string>u16-memory } ; +{ $subsection alien>u16-string } ; ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code." diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index a67c7f4fb9..91089a8278 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -155,20 +155,9 @@ M: float-array byte-length length "double" heap-size * ; : memory>byte-array ( alien len -- byte-array ) dup [ -rot memcpy ] keep ; -: memory>char-string ( alien len -- string ) - memory>byte-array >string ; - -DEFER: c-ushort-array> - -: memory>u16-string ( alien len -- string ) - [ memory>byte-array ] keep 2/ c-ushort-array> >string ; - : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; -: string>char-memory ( string base -- ) - >r B{ } like r> byte-array>memory ; - DEFER: >c-ushort-array : string>u16-memory ( string base -- ) @@ -274,7 +263,7 @@ M: long-long-type box-return ( type -- ) ] when ; : malloc-file-contents ( path -- alien ) - binary file-contents >byte-array malloc-byte-array ; + binary file-contents malloc-byte-array ; [ [ alien-cell ] diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor index f6d103b0d1..33677fdc81 100755 --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,8 +1,8 @@ USING: io.binary tools.test ; IN: io.binary.tests -[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test -[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test +[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test +[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test [ 1234 ] [ 1234 4 >be be> ] unit-test [ 1234 ] [ 1234 4 >le le> ] unit-test diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index e7f7f4f777..e2eeef6528 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -6,9 +6,8 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ - "test-foo.txt" temp-file ascii [ - "Hello world." print - ] with-file-writer + { "Hello world." } + "test-foo.txt" temp-file ascii set-file-lines ] unit-test [ ] [ @@ -69,8 +68,8 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test [ ] [ - "delete-tree-test/a/b/c/d" temp-file - ascii [ "Hi" print ] with-file-writer + { "Hi" } + "delete-tree-test/a/b/c/d" temp-file ascii set-file-lines ] unit-test [ ] [ @@ -82,8 +81,9 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; ] unit-test [ ] [ + "Foobar" "copy-tree-test/a/b/c/d" temp-file - ascii [ "Foobar" write ] with-file-writer + ascii set-file-contents ] unit-test [ ] [ diff --git a/core/io/files/files.factor b/core/io/files/files.factor index e3cf94f8b3..cbb6e77ff9 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -213,15 +213,15 @@ C: pathname M: pathname <=> [ pathname-string ] compare ; -: file-lines ( path encoding -- seq ) lines ; - -: file-contents ( path encoding -- str ) - dupd swap file-length - [ stream-copy ] keep >string ; +: file-lines ( path encoding -- seq ) + lines ; : with-file-reader ( path encoding quot -- ) >r r> with-stream ; inline +: file-contents ( path encoding -- str ) + dupd [ file-length read ] with-file-reader ; + : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 321cad4d19..4a3d94a172 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -3,9 +3,7 @@ io.encodings.ascii strings ; IN: io.streams.c.tests [ "hello world" ] [ - "test.txt" temp-file ascii [ - "hello world" write - ] with-file-writer + "hello world" "test.txt" temp-file ascii set-file-contents "test.txt" temp-file "rb" fopen contents >string diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index ef12543d52..6420eb9cbc 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.buffers USING: alien alien.accessors alien.c-types alien.syntax kernel -kernel.private libc math sequences strings hints ; +kernel.private libc math sequences byte-arrays strings hints ; TUPLE: buffer size ptr fill pos ; @@ -37,18 +37,18 @@ TUPLE: buffer size ptr fill pos ; : buffer-pop ( buffer -- ch ) dup buffer-peek 1 rot buffer-consume ; -: (buffer>) ( n buffer -- string ) +: (buffer>) ( n buffer -- byte-array ) [ dup buffer-fill swap buffer-pos - min ] keep - buffer@ swap memory>char-string ; + buffer@ swap memory>byte-array ; -: buffer> ( n buffer -- string ) +: buffer> ( n buffer -- byte-array ) [ (buffer>) ] 2keep buffer-consume ; -: (buffer>>) ( buffer -- string ) +: (buffer>>) ( buffer -- byte-array ) dup buffer-pos over buffer-ptr - over buffer-fill rot buffer-pos - memory>char-string ; + over buffer-fill rot buffer-pos - memory>byte-array ; -: buffer>> ( buffer -- string ) +: buffer>> ( buffer -- byte-array ) dup (buffer>>) 0 rot buffer-reset ; : search-buffer-until ( start end alien separators -- n ) @@ -56,7 +56,7 @@ TUPLE: buffer size ptr fill pos ; HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; -: finish-buffer-until ( buffer n -- string separator ) +: finish-buffer-until ( buffer n -- byte-array separator ) [ over buffer-pos - over buffer> @@ -65,7 +65,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; buffer>> f ] if* ; -: buffer-until ( separators buffer -- string separator ) +: buffer-until ( separators buffer -- byte-array separator ) tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll search-buffer-until finish-buffer-until ; @@ -85,9 +85,9 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; : check-overflow ( n buffer -- ) 2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ; -: >buffer ( string buffer -- ) +: >buffer ( byte-array buffer -- ) over length over check-overflow - [ buffer-end string>char-memory ] 2keep + [ buffer-end byte-array>memory ] 2keep [ buffer-fill swap length + ] keep set-buffer-fill ; : ch>buffer ( ch buffer -- ) diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index 81c3faec1e..f1c65178d9 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -3,7 +3,7 @@ sequences io.encodings.ascii ; IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors -[ ] [ "mmap-test-file.txt" resource-path ascii [ "12345" write ] with-file-writer ] unit-test +[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 1d472c19a3..73090ea724 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - >r dup file-permissions over r> (copy-file) chmod io-error ; + [ (copy-file) ] 2keep swap file-permissions chmod io-error ; : stat>type ( stat -- type ) stat-st_mode { From 7ffd9c95baf0fa58de7a01711074c0823b424d04 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 21:27:00 -0600 Subject: [PATCH 45/63] Fixing interval comparison --- core/math/intervals/intervals-tests.factor | 107 +++++++++++++++++---- core/math/intervals/intervals.factor | 99 +++++++++++++------ core/optimizer/math/math.factor | 10 +- 3 files changed, 166 insertions(+), 50 deletions(-) diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 8e2f47f72b..997b3453f2 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -1,5 +1,5 @@ USING: math.intervals kernel sequences words math arrays -prettyprint tools.test random vocabs ; +prettyprint tools.test random vocabs combinators ; IN: math.intervals.tests [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test @@ -94,33 +94,86 @@ IN: math.intervals.tests ] unit-test ] when -[ t ] [ 0 5 [a,b] 5 interval<= ] unit-test +[ t ] [ 1 [a,a] interval-singleton? ] unit-test -[ incomparable ] [ 0 5 [a,b] 5 interval< ] unit-test +[ f ] [ 1 1 [a,b) interval-singleton? ] unit-test -[ t ] [ 0 5 [a,b) 5 interval< ] unit-test +[ f ] [ 1 3 [a,b) interval-singleton? ] unit-test -[ f ] [ 0 5 [a,b] -1 interval< ] unit-test +[ f ] [ 1 1 (a,b) interval-singleton? ] unit-test -[ incomparable ] [ 0 5 [a,b] 1 interval< ] unit-test +[ 2 ] [ 1 3 [a,b) interval-length ] unit-test -[ t ] [ -1 1 (a,b) -1 interval> ] unit-test +[ 0 ] [ f interval-length ] unit-test -[ t ] [ -1 1 (a,b) -1 interval>= ] unit-test +[ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test -[ f ] [ -1 1 (a,b) -1 interval< ] unit-test +[ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test -[ f ] [ -1 1 (a,b) -1 interval<= ] unit-test +[ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test -[ t ] [ -1 1 (a,b] 1 interval<= ] unit-test +[ f ] [ 0 5 [a,b] -1 [a,a] interval< ] unit-test + +[ incomparable ] [ 0 5 [a,b] 1 [a,a] interval< ] unit-test + +[ t ] [ -1 1 (a,b) -1 [a,a] interval> ] unit-test + +[ t ] [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test + +[ f ] [ -1 1 (a,b) -1 [a,a] interval< ] unit-test + +[ f ] [ -1 1 (a,b) -1 [a,a] interval<= ] unit-test + +[ t ] [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test + +[ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test + +[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test + +[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test + +[ t ] [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test + +[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test + +[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test + +[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test + +[ incomparable ] [ 10 [a,a] 0 10 [a,b] interval> ] unit-test + +[ t ] [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test + +[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test + +[ t ] [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test + +[ t ] [ + 418 + 418 423 [a,b) + 79 893 (a,b] + interval-max + interval-contains? +] unit-test ! Interval random tester : random-element ( interval -- n ) - dup interval-to first swap interval-from first tuck - - random + ; + dup interval-to first over interval-from first tuck - random + + 2dup swap interval-contains? [ + nip + ] [ + drop random-element + ] if ; : random-interval ( -- interval ) - 1000 random dup 1 1000 random + + [a,b] ; + 1000 random dup 2 1000 random + + + 1 random zero? [ [ neg ] 2apply swap ] when + 4 random { + { 0 [ [a,b] ] } + { 1 [ [a,b) ] } + { 2 [ (a,b) ] } + { 3 [ (a,b] ] } + } case ; : random-op { @@ -138,12 +191,32 @@ IN: math.intervals.tests random ; : interval-test - random-interval random-interval random-op + random-interval random-interval random-op ! 3dup . . . 0 pick interval-contains? over first { / /i } member? and [ 3drop t ] [ - [ >r [ random-element ] 2apply r> first execute ] 3keep + [ >r [ random-element ] 2apply ! 2dup . . + r> first execute ] 3keep second execute interval-contains? ] if ; -[ t ] [ 1000 [ drop interval-test ] all? ] unit-test +[ t ] [ 4000 [ drop interval-test ] all? ] unit-test + +: random-comparison + { + { < interval< } + { <= interval<= } + { > interval> } + { >= interval>= } + } random ; + +: comparison-test + random-interval random-interval random-comparison + [ >r [ random-element ] 2apply r> first execute ] 3keep + second execute dup incomparable eq? [ + 2drop t + ] [ + = + ] if ; + +[ t ] [ 4000 [ drop comparison-test ] all? ] unit-test diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index b7eb5be8c9..d4cb8d2dce 100644 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -88,20 +88,6 @@ C: interval [ interval>points [ first integer? ] both? ] both? r> [ 2drop f ] if ; inline -: interval-shift ( i1 i2 -- i3 ) - [ [ shift ] interval-op ] interval-integer-op ; - -: interval-shift-safe ( i1 i2 -- i3 ) - dup interval-to first 100 > [ - 2drop f - ] [ - interval-shift - ] if ; - -: interval-max ( i1 i2 -- i3 ) [ max ] interval-op ; - -: interval-min ( i1 i2 -- i3 ) [ min ] interval-op ; - : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ; : interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ; @@ -143,9 +129,42 @@ C: interval : interval-contains? ( x int -- ? ) >r [a,a] r> interval-subset? ; +: interval-singleton? ( int -- ? ) + interval>points + 2dup [ second ] 2apply and + [ [ first ] 2apply = ] + [ 2drop f ] if ; + +: interval-length ( int -- n ) + dup + [ interval>points [ first ] 2apply swap - ] + [ drop 0 ] if ; + : interval-closure ( i1 -- i2 ) interval>points [ first ] 2apply [a,b] ; +: interval-shift ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ [ shift ] interval-op ] interval-integer-op interval-closure ; + +: interval-shift-safe ( i1 i2 -- i3 ) + dup interval-to first 100 > [ + 2drop f + ] [ + interval-shift + ] if ; + +: interval-max ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ max ] interval-op interval-closure ; + +: interval-min ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ min ] interval-op interval-closure ; + +: interval-interior ( i1 -- i2 ) + interval>points [ first ] 2apply (a,b) ; + : interval-division-op ( i1 i2 quot -- i3 ) >r 0 over interval-closure interval-contains? [ 2drop f ] r> if ; inline @@ -156,7 +175,7 @@ C: interval : interval/i ( i1 i2 -- i3 ) [ [ [ /i ] interval-op ] interval-integer-op - ] interval-division-op ; + ] interval-division-op interval-closure ; : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; @@ -164,24 +183,46 @@ C: interval SYMBOL: incomparable -: interval-compare ( int n quot -- ? ) - >r dupd r> call interval-intersect dup [ - = t incomparable ? - ] [ - 2drop f - ] if ; inline +: left-endpoint-< ( i1 i2 -- ? ) + [ swap interval-subset? ] 2keep + [ nip interval-singleton? ] 2keep + [ interval-from ] 2apply = + and and ; -: interval< ( int n -- ? ) - [ [-inf,a) ] interval-compare ; inline +: right-endpoint-< ( i1 i2 -- ? ) + [ interval-subset? ] 2keep + [ drop interval-singleton? ] 2keep + [ interval-to ] 2apply = + and and ; -: interval<= ( int n -- ? ) - [ [-inf,a] ] interval-compare ; inline +: (interval<) over interval-from over interval-from endpoint< ; -: interval> ( int n -- ? ) - [ (a,inf] ] interval-compare ; inline +: interval< ( i1 i2 -- ? ) + { + { [ 2dup interval-intersect not ] [ (interval<) ] } + { [ 2dup left-endpoint-< ] [ f ] } + { [ 2dup right-endpoint-< ] [ f ] } + { [ t ] [ incomparable ] } + } cond 2nip ; -: interval>= ( int n -- ? ) - [ [a,inf] ] interval-compare ; inline +: left-endpoint-<= ( i1 i2 -- ? ) + >r interval-from r> interval-to = ; + +: right-endpoint-<= ( i1 i2 -- ? ) + >r interval-to r> interval-from = ; + +: interval<= ( i1 i2 -- ? ) + { + { [ 2dup interval-intersect not ] [ (interval<) ] } + { [ 2dup right-endpoint-<= ] [ t ] } + { [ t ] [ incomparable ] } + } cond 2nip ; + +: interval> ( i1 i2 -- ? ) + swap interval< ; + +: interval>= ( i1 i2 -- ? ) + swap interval<= ; : assume< ( i1 i2 -- i3 ) interval-to first [-inf,a) interval-intersect ; diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index b7c82e402a..7afc177d10 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -371,13 +371,15 @@ most-negative-fixnum most-positive-fixnum [a,b] ] assoc-each ! Remove redundant comparisons -: known-comparison? ( #call -- ? ) +: intervals-first2 ( #call -- first second ) dup dup node-in-d first node-interval - swap dup node-in-d second node-literal real? and ; + swap dup node-in-d second node-interval ; + +: known-comparison? ( #call -- ? ) + intervals-first2 and ; : perform-comparison ( #call word -- result ) - >r dup dup node-in-d first node-interval - swap dup node-in-d second node-literal r> execute ; inline + >r intervals-first2 r> execute ; inline : foldable-comparison? ( #call word -- ? ) >r dup known-comparison? [ From 4b130d4fdecc85f31b2f8a764ef2a55b7a6f0704 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 21:27:49 -0600 Subject: [PATCH 46/63] Remove obsolete dir --- extra/sqlite/sqlite.factor | 156 ------------------------------------- 1 file changed, 156 deletions(-) delete mode 100644 extra/sqlite/sqlite.factor diff --git a/extra/sqlite/sqlite.factor b/extra/sqlite/sqlite.factor deleted file mode 100644 index 63d9d64237..0000000000 --- a/extra/sqlite/sqlite.factor +++ /dev/null @@ -1,156 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -! An interface to the sqlite database. Tested against sqlite v3.0.8. -! -! Not all functions have been wrapped yet. Only those directly involving -! executing SQL calls and obtaining results. -! -IN: sqlite -USING: alien compiler io.files.tmp kernel math namespaces sequences strings - sqlite.lib alien.c-types continuations ; - -TUPLE: sqlite-error n message ; -SYMBOL: db - -! High level sqlite routines -: sqlite-check-result ( result -- ) - #! Check the result from a sqlite call is ok. If it is - #! return, otherwise throw an error. - dup SQLITE_OK = [ - drop - ] [ - dup sqlite-error-messages nth - \ sqlite-error construct-boa throw - ] if ; - -: sqlite-open ( filename -- db ) - #! Open the database referenced by the filename and return - #! a handle to that database. An error is thrown if the database - #! failed to open. - "void*" [ sqlite3_open sqlite-check-result ] keep *void* ; - -: sqlite-close ( db -- ) - #! Close the given database - sqlite3_close sqlite-check-result ; - -: sqlite-last-insert-rowid ( db -- rowid ) - #! Return the rowid of the last insert - sqlite3_last_insert_rowid ; - -: sqlite-prepare ( db sql -- statement ) - #! Prepare a SQL statement. Returns the statement which - #! can have values bound to parameters or simply executed. - #! TODO: Support multiple statements in the SQL string. - dup length "void*" "void*" - [ sqlite3_prepare sqlite-check-result ] 2keep - drop *void* ; - -: sqlite-bind-text ( statement index text -- ) - #! Bind the text to the parameterized value in the statement. - dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ; - -: sqlite-bind-int ( statement index int -- ) - sqlite3_bind_int sqlite-check-result ; - -GENERIC: sqlite-bind ( statement index obj -- ) - -M: object sqlite-bind ( statement index obj -- ) - sqlite-bind-text ; - -M: integer sqlite-bind ( statement index int -- ) - sqlite-bind-int ; - -: sqlite-bind-parameter-index ( statement name -- index ) - sqlite3_bind_parameter_index ; - -: sqlite-bind-text-by-name ( statement name text -- ) - >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ; - -: sqlite-bind-by-name ( statement name obj -- ) - >r dupd sqlite-bind-parameter-index r> sqlite-bind ; - -GENERIC# sqlite-bind-by-name-or-index 1 ( statement key val -- ) - -M: object sqlite-bind-by-name-or-index ( statement object val -- ) - sqlite-bind-by-name ; - -M: integer sqlite-bind-by-name-or-index ( statement integer val -- ) - sqlite-bind ; - -: sqlite-finalize ( statement -- ) - #! Clean up all resources related to a statement. Once called - #! the statement cannot be used. All statements must be finalized - #! before closing the database. - sqlite3_finalize sqlite-check-result ; - -: sqlite-reset ( statement -- ) - #! Reset a statement so it can be called again, possibly with - #! different parameters. - sqlite3_reset sqlite-check-result ; - -: column-count ( statement -- int ) - #! Given a prepared statement, return the number of - #! columns in each row of the result set of that statement. - sqlite3_column_count ; - -: column-text ( statement index -- string ) - #! Return the value of the given column, indexed - #! from zero, as a string. - sqlite3_column_text ; - -: column-int ( statement index -- int ) - sqlite3_column_int ; - -: step-complete? ( step-result -- bool ) - #! Return true if the result of a sqlite3_step is - #! such that the iteration has completed (ie. it is - #! SQLITE_DONE). Throw an error if an error occurs. - dup SQLITE_ROW = [ - drop f - ] [ - dup SQLITE_DONE = [ - drop t - ] [ - sqlite-check-result t - ] if - ] if ; - -: sqlite-each ( statement quot -- ) - #! Execute the SQL statement, and call the quotation for - #! each row returned from executing the statement with the - #! statement on the top of the stack. - over sqlite3_step step-complete? [ - 2drop - ] [ - [ call ] 2keep sqlite-each - ] if ; inline - -! For comparison, here is the linrec implementation of sqlite-each -! [ drop sqlite3_step step-complete? ] -! [ 2drop ] -! [ 2dup 2slip ] -! [ ] linrec ; - -DEFER: (sqlite-map) - -: (sqlite-map) ( statement quot seq -- ) - pick sqlite3_step step-complete? [ - 2nip - ] [ - >r 2dup call r> swap add (sqlite-map) - ] if ; - -: sqlite-map ( statement quot -- seq ) - { } (sqlite-map) ; - -: with-sqlite ( path quot -- ) - [ - >r sqlite-open db set r> - [ db get sqlite-close ] [ ] cleanup - ] with-scope ; - -: with-tmp-db ( quot -- ) - ".db" [ - swap with-sqlite - ] with-tmpfile ; From 8c645f7a45c3a88aeabc9f72305baaea22b71ee2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 21:28:04 -0600 Subject: [PATCH 47/63] Tweak msxml-to-csv --- extra/msxml-to-csv/msxml-to-csv.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 3004324511..839fcaaf54 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -1,8 +1,7 @@ -USING: io io.files sequences xml xml.utilities io.encodings.utf8 ; +USING: io io.files sequences xml xml.utilities +io.encodings.ascii kernel ; IN: msxml-to-csv -: print-csv ( table -- ) [ "," join print ] each ; - : (msxml>csv) ( xml -- table ) "Worksheet" tag-named "Table" tag-named @@ -12,7 +11,6 @@ IN: msxml-to-csv ] map ] map ; -: msxml>csv ( infile outfile -- ) - utf8 [ - file>xml (msxml>csv) print-csv - ] with-file-writer ; +: msxml>csv ( outfile infile -- ) + file>xml (msxml>csv) [ "," join ] map + swap ascii set-file-lines ; From 7b0b174115bcb83fbada49f19c01631b298000b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 21:28:11 -0600 Subject: [PATCH 48/63] Use set-file-contents --- extra/tools/browser/browser.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 24836c1201..c189a6f9de 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -17,8 +17,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ - ?resource-path - utf8 [ [ print ] each ] with-file-writer + ?resource-path utf8 set-file-lines ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" From 33b3f1b3b4771b2fd97ab75ba56468c53e59296d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 21:28:51 -0600 Subject: [PATCH 49/63] Fixing deploy --- extra/cocoa/plists/plists.factor | 4 ++-- extra/tools/deploy/backend/backend.factor | 4 ++-- extra/tools/deploy/macosx/macosx.factor | 18 ++++++++++-------- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/extra/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor index 646a759c59..5965c74af8 100644 --- a/extra/cocoa/plists/plists.factor +++ b/extra/cocoa/plists/plists.factor @@ -19,5 +19,5 @@ M: hashtable >plist >plist 1array "plist" build-tag* dup { { "version" "1.0" } } update ; -: print-plist ( obj -- ) - build-plist build-xml print-xml ; +: plist>string ( obj -- string ) + build-plist build-xml xml>string ; diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 6e8a231b81..301ffa3378 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -23,7 +23,7 @@ IN: tools.deploy.backend +closed+ >>stdin utf8 dup copy-lines - process-stream-process wait-for-process zero? [ + process>> wait-for-process zero? [ "Deployment failed" throw ] unless ; @@ -61,7 +61,7 @@ IN: tools.deploy.backend ] { } make ; : run-factor ( vm flags -- ) - dup . swap add* run-with-output ; inline + swap add* dup . run-with-output ; inline : make-staging-image ( vm config -- ) staging-command-line run-factor ; diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 6cab5c98b9..6db19cf868 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -9,17 +9,18 @@ IN: tools.deploy.macosx : bundle-dir ( -- dir ) vm parent-directory parent-directory ; -: copy-bundle-dir ( name dir -- ) - bundle-dir swap path+ swap "Contents" path+ copy-tree ; +: copy-bundle-dir ( bundle-name dir -- ) + bundle-dir over path+ -rot + "Contents" swap path+ path+ copy-tree ; : copy-vm ( executable bundle-name -- vm ) "Contents/MacOS/" path+ swap path+ vm over copy-file ; : copy-fonts ( name -- ) "fonts/" resource-path - swap "Contents/Resources/" path+ copy-tree ; + swap "Contents/Resources/" path+ copy-tree-into ; -: print-app-plist ( executable bundle-name -- ) +: app-plist ( executable bundle-name -- string ) [ namespace { { "CFBundleInfoDictionaryVersion" "6.0" } @@ -30,11 +31,12 @@ IN: tools.deploy.macosx dup "CFBundleExecutable" set "org.factor." swap append "CFBundleIdentifier" set - ] H{ } make-assoc print-plist ; + ] H{ } make-assoc plist>string ; : create-app-plist ( vocab bundle-name -- ) - dup "Contents/Info.plist" path+ - utf8 [ print-app-plist ] with-file-writer ; + [ app-plist ] keep + "Contents/Info.plist" path+ + utf8 set-file-contents ; : create-app-dir ( vocab bundle-name -- vm ) dup "Frameworks" copy-bundle-dir @@ -62,7 +64,7 @@ M: macosx-deploy-implementation deploy* ( vocab -- ) ".app deploy tool" assert.app "." resource-path cd dup deploy-config [ - bundle-name delete-tree + bundle-name dup exists? [ delete-tree ] [ drop ] if [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep namespace make-deploy-image From 44cef753daeb596474d1aeb2ceb62a5dc82b206f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 21:29:04 -0600 Subject: [PATCH 50/63] Benchmarks can use ascii encoding --- extra/benchmark/mandel/mandel.factor | 6 +++--- extra/benchmark/raytracer/raytracer.factor | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 05eda2ad81..0f8c81da75 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,6 +1,7 @@ IN: benchmark.mandel USING: arrays io kernel math namespaces sequences strings sbufs -math.functions math.parser io.files colors.hsv io.encodings.binary ; +math.functions math.parser io.files colors.hsv +io.encodings.ascii ; : max-color 360 ; inline : zoom-fact 0.8 ; inline @@ -65,7 +66,6 @@ SYMBOL: cols ] with-scope ; : mandel-main ( -- ) - "mandel.ppm" temp-file - binary [ mandel write ] with-file-writer ; + mandel "mandel.ppm" temp-file ascii set-file-contents ; MAIN: mandel-main diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 232842a51e..4bb8c30383 100644 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -3,7 +3,7 @@ USING: float-arrays compiler generic io io.files kernel math math.functions math.vectors math.parser namespaces sequences -sequences.private words io.encodings.binary ; +sequences.private words io.encodings.ascii ; IN: benchmark.raytracer ! parameters @@ -170,7 +170,6 @@ DEFER: create ( level c r -- scene ) ] "" make ; : raytracer-main - "raytracer.pnm" temp-file - binary [ run write ] with-file-writer ; + run "raytracer.pnm" temp-file ascii set-file-contents ; MAIN: raytracer-main From 28182f06f9719220e489c3d67119b151d8696f7f Mon Sep 17 00:00:00 2001 From: dharmatech Date: Fri, 7 Mar 2008 23:47:11 -0600 Subject: [PATCH 51/63] Fix download-to --- extra/http/client/client.factor | 4 ++-- extra/io/encodings/ascii/ascii.factor | 2 +- extra/io/encodings/latin1/latin1.factor | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index f011ff537e..0d733ba97d 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -82,8 +82,8 @@ PRIVATE> : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - swap http-get-stream check-response - [ swap binary stream-copy ] with-disposal ; + swap http-get-stream swap check-response + [ swap latin1 stream-copy ] with-disposal ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index fdefc35634..1c50e4c2a4 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -9,7 +9,7 @@ IN: io.encodings.ascii TUPLE: ascii ; M: ascii stream-write-encoded ( string stream encoding -- ) - drop 127 encode-check<= ; + drop 128 encode-check<= ; M: ascii decode-step drop dup 128 >= [ decode-error ] [ swap push ] if ; diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index 989f45bc64..3cb361b2fd 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/extra/io/encodings/latin1/latin1.factor @@ -6,7 +6,7 @@ IN: io.encodings.latin1 TUPLE: latin1 ; M: latin1 stream-write-encoded - drop 255 encode-check<= ; + drop 256 encode-check<= ; M: latin1 decode-step - drop dup 256 >= [ decode-error ] [ swap push ] if ; + drop swap push ; From 4de55d071684755d98ec3f4a2792c42ab5e2ebb3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 8 Mar 2008 00:13:35 -0600 Subject: [PATCH 52/63] fix typos --- extra/crypto/sha1/sha1.factor | 2 +- extra/crypto/sha2/sha2.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index e2398311b7..efccbc6e5b 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -6,7 +6,7 @@ IN: crypto.sha1 ! Implemented according to RFC 3174. -SYMBOL: h0 h1 h2 h3 h4 A B C D E w K ; +SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; : get-wth ( n -- wth ) w get nth ; inline : shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor index 07d38b83bb..6935db82a9 100644 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -4,7 +4,7 @@ IN: crypto.sha2 word ; +SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ; : a 0 ; : b 1 ; From 7ad74eb32011bd3c21ee942ad9197b889ad48ac4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Mar 2008 02:51:26 -0600 Subject: [PATCH 53/63] Various fixes --- core/io/binary/binary-tests.factor | 4 +- core/io/binary/binary.factor | 2 +- core/io/encodings/utf8/utf8-tests.factor | 2 +- core/layouts/layouts.factor | 4 + core/listener/listener-tests.factor | 22 +- core/math/integers/integers.factor | 2 +- core/math/intervals/intervals-tests.factor | 6 +- core/math/intervals/intervals.factor | 2 +- extra/crypto/hmac/hmac-tests.factor | 15 +- extra/crypto/hmac/hmac.factor | 11 +- extra/crypto/md5/md5-docs.factor | 10 +- extra/crypto/md5/md5-tests.factor | 16 +- extra/crypto/md5/md5.factor | 17 +- extra/crypto/sha1/sha1-tests.factor | 8 +- extra/crypto/sha1/sha1.factor | 29 ++- extra/crypto/sha2/sha2-tests.factor | 12 +- extra/crypto/sha2/sha2.factor | 16 +- extra/db/mysql/mysql.factor | 26 +-- extra/hello-ui/deploy.factor | 13 +- .../templating/fhtml/fhtml-tests.factor | 7 +- extra/io/buffers/buffers-docs.factor | 24 +- extra/io/buffers/buffers-tests.factor | 30 +-- extra/io/buffers/buffers.factor | 2 +- extra/io/nonblocking/nonblocking-docs.factor | 8 +- extra/io/nonblocking/nonblocking.factor | 4 +- extra/io/windows/nt/monitors/monitors.factor | 5 +- extra/koszul/koszul-tests.factor | 3 +- extra/serialize/serialize-docs.factor | 10 +- extra/serialize/serialize-tests.factor | 43 +++- extra/serialize/serialize.factor | 221 ++++++++++-------- 30 files changed, 325 insertions(+), 249 deletions(-) mode change 100644 => 100755 core/io/encodings/utf8/utf8-tests.factor mode change 100644 => 100755 core/math/intervals/intervals.factor mode change 100644 => 100755 extra/crypto/hmac/hmac.factor mode change 100644 => 100755 extra/crypto/md5/md5-docs.factor mode change 100644 => 100755 extra/crypto/md5/md5-tests.factor mode change 100644 => 100755 extra/crypto/md5/md5.factor mode change 100644 => 100755 extra/crypto/sha1/sha1.factor mode change 100644 => 100755 extra/crypto/sha2/sha2-tests.factor mode change 100644 => 100755 extra/crypto/sha2/sha2.factor mode change 100644 => 100755 extra/db/mysql/mysql.factor mode change 100644 => 100755 extra/io/buffers/buffers-docs.factor mode change 100644 => 100755 extra/koszul/koszul-tests.factor mode change 100644 => 100755 extra/serialize/serialize-docs.factor diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor index 33677fdc81..a6fea14fc7 100755 --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,4 +1,4 @@ -USING: io.binary tools.test ; +USING: io.binary tools.test classes math ; IN: io.binary.tests [ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test @@ -6,3 +6,5 @@ IN: io.binary.tests [ 1234 ] [ 1234 4 >be be> ] unit-test [ 1234 ] [ 1234 4 >le le> ] unit-test + +[ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index 9f6231b643..f2ede93fd5 100755 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -3,7 +3,7 @@ USING: kernel math sequences ; IN: io.binary -: le> ( seq -- x ) B{ } like byte-array>bignum ; +: le> ( seq -- x ) B{ } like byte-array>bignum >integer ; : be> ( seq -- x ) le> ; : mask-byte ( x -- y ) HEX: ff bitand ; inline diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor old mode 100644 new mode 100755 index 8f1c998f3d..25eae5ae22 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,4 +1,4 @@ -USING: io.encodings.utf8 tools.test io.encodings.string strings arrays ; +USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ; : decode-utf8-w/stream ( array -- newarray ) utf8 decode >array ; diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index cba3532d9f..db23bf03d0 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -33,6 +33,10 @@ SYMBOL: type-numbers : most-negative-fixnum ( -- n ) first-bignum neg ; +M: bignum >integer + dup most-negative-fixnum most-positive-fixnum between? + [ >fixnum ] when ; + M: real >integer dup most-negative-fixnum most-positive-fixnum between? [ >fixnum ] [ >bignum ] if ; diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index d694c62c67..2c05c049a7 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -8,9 +8,11 @@ IN: listener.tests : parse-interactive ( string -- quot ) stream-read-quot ; -[ [ ] ] [ - "USE: listener.tests hello" parse-interactive -] unit-test +[ + [ [ ] ] [ + "USE: listener.tests hello" parse-interactive + ] unit-test +] with-file-vocabs [ "debugger" use+ @@ -35,8 +37,10 @@ IN: listener.tests ] unit-test [ - "USE: vocabs.loader.test.c" parse-interactive -] must-fail + [ + "USE: vocabs.loader.test.c" parse-interactive + ] must-fail +] with-file-vocabs [ ] [ [ @@ -44,7 +48,9 @@ IN: listener.tests ] with-compilation-unit ] unit-test -[ ] [ - "IN: listener.tests : hello\n\"world\" ;" parse-interactive +[ + [ ] [ + "IN: listener.tests : hello\n\"world\" ;" parse-interactive drop -] unit-test + ] unit-test +] with-file-vocabs diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 011af6342e..70a6d2e087 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -6,10 +6,10 @@ IN: math.integers.private M: integer numerator ; M: integer denominator drop 1 ; -M: integer >integer ; M: fixnum >fixnum ; M: fixnum >bignum fixnum>bignum ; +M: fixnum >integer ; M: fixnum number= eq? ; diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 997b3453f2..5a3fe777b6 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -156,6 +156,8 @@ IN: math.intervals.tests interval-contains? ] unit-test +[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test + ! Interval random tester : random-element ( interval -- n ) dup interval-to first over interval-from first tuck - random + @@ -200,7 +202,7 @@ IN: math.intervals.tests second execute interval-contains? ] if ; -[ t ] [ 4000 [ drop interval-test ] all? ] unit-test +[ t ] [ 40000 [ drop interval-test ] all? ] unit-test : random-comparison { @@ -219,4 +221,4 @@ IN: math.intervals.tests = ] if ; -[ t ] [ 4000 [ drop comparison-test ] all? ] unit-test +[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor old mode 100644 new mode 100755 index d4cb8d2dce..d1c458065f --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -141,7 +141,7 @@ C: interval [ drop 0 ] if ; : interval-closure ( i1 -- i2 ) - interval>points [ first ] 2apply [a,b] ; + dup [ interval>points [ first ] 2apply [a,b] ] when ; : interval-shift ( i1 i2 -- i3 ) #! Inaccurate; could be tighter diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index 35c99258db..fa0cbef4c7 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -1,11 +1,12 @@ -USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ; +USING: kernel io strings byte-arrays sequences namespaces math +parser crypto.hmac tools.test ; IN: crypto.hmac.tests -[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test -[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test -[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd string>md5-hmac >string ] unit-test +[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" byte-array>md5-hmac >string ] unit-test +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test +[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>md5-hmac >string ] unit-test -[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" string>sha1-hmac >string ] unit-test -[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test -[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd string>sha1-hmac >string ] unit-test +[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test +[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test +[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor old mode 100644 new mode 100755 index 56d39e71dc..3dad01fe3a --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -1,5 +1,5 @@ USING: arrays combinators crypto.common crypto.md5 crypto.sha1 -crypto.md5.private io io.binary io.files io.streams.string +crypto.md5.private io io.binary io.files io.streams.byte-array kernel math math.vectors memoize sequences io.encodings.binary ; IN: crypto.hmac @@ -34,8 +34,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : file>sha1-hmac ( K path -- hmac ) binary stream>sha1-hmac ; -: string>sha1-hmac ( K string -- hmac ) - stream>sha1-hmac ; +: byte-array>sha1-hmac ( K string -- hmac ) + binary stream>sha1-hmac ; : stream>md5-hmac ( K stream -- hmac ) @@ -44,6 +44,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : file>md5-hmac ( K path -- hmac ) binary stream>md5-hmac ; -: string>md5-hmac ( K string -- hmac ) - stream>md5-hmac ; - +: byte-array>md5-hmac ( K string -- hmac ) + binary stream>md5-hmac ; diff --git a/extra/crypto/md5/md5-docs.factor b/extra/crypto/md5/md5-docs.factor old mode 100644 new mode 100755 index fd8bf3f74d..667e0449ae --- a/extra/crypto/md5/md5-docs.factor +++ b/extra/crypto/md5/md5-docs.factor @@ -1,15 +1,15 @@ USING: help.markup help.syntax kernel math sequences quotations -crypto.common ; +crypto.common byte-arrays ; IN: crypto.md5 HELP: stream>md5 { $values { "stream" "a stream" } { "byte-array" "md5 hash" } } { $description "Take the MD5 hash until end of stream." } -{ $notes "Used to implement " { $link string>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ; +{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ; -HELP: string>md5 -{ $values { "string" "a string" } { "byte-array" "byte-array md5 hash" } } -{ $description "Outputs the MD5 hash of a string." } +HELP: byte-array>md5 +{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } } +{ $description "Outputs the MD5 hash of a byte array." } { $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ; HELP: file>md5 diff --git a/extra/crypto/md5/md5-tests.factor b/extra/crypto/md5/md5-tests.factor old mode 100644 new mode 100755 index 9a361eb594..73bd240455 --- a/extra/crypto/md5/md5-tests.factor +++ b/extra/crypto/md5/md5-tests.factor @@ -1,10 +1,10 @@ -USING: kernel math namespaces crypto.md5 tools.test ; +USING: kernel math namespaces crypto.md5 tools.test byte-arrays ; -[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test -[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test -[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test -[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test -[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test -[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test -[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test +[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test +[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test +[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test +[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test +[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test +[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test +[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor old mode 100644 new mode 100755 index 224b203fba..7ecbd767b9 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -1,6 +1,6 @@ ! See http://www.faqs.org/rfcs/rfc1321.html -USING: kernel io io.binary io.files io.streams.string math +USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting strings sequences crypto.common byte-arrays locals sequences.private io.encodings.binary symbols ; @@ -178,7 +178,14 @@ PRIVATE> : stream>md5 ( stream -- byte-array ) [ initialize-md5 (stream>md5) get-md5 ] with-stream ; -: string>md5 ( string -- byte-array ) stream>md5 ; -: string>md5str ( string -- md5-string ) string>md5 hex-string ; -: file>md5 ( path -- byte-array ) binary stream>md5 ; -: file>md5str ( path -- md5-string ) file>md5 hex-string ; +: byte-array>md5 ( byte-array -- checksum ) + binary stream>md5 ; + +: byte-array>md5str ( byte-array -- md5-string ) + byte-array>md5 hex-string ; + +: file>md5 ( path -- byte-array ) + binary stream>md5 ; + +: file>md5str ( path -- md5-string ) + file>md5 hex-string ; diff --git a/extra/crypto/sha1/sha1-tests.factor b/extra/crypto/sha1/sha1-tests.factor index 795ee4971d..14307355c2 100755 --- a/extra/crypto/sha1/sha1-tests.factor +++ b/extra/crypto/sha1/sha1-tests.factor @@ -1,14 +1,14 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ; -[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test -[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test +[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test +[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test ! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... [ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" -10 swap concat string>sha1str ] unit-test +10 swap concat byte-array>sha1str ] unit-test [ ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099" ] [ "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7" - string>sha1-interleave + byte-array>sha1-interleave ] unit-test diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor old mode 100644 new mode 100755 index efccbc6e5b..af3671e7d9 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,7 +1,7 @@ -USING: arrays combinators crypto.common kernel io io.encodings.binary -io.files io.streams.string math.vectors strings sequences -namespaces math parser sequences vectors io.binary -hashtables symbols ; +USING: arrays combinators crypto.common kernel io +io.encodings.binary io.files io.streams.byte-array math.vectors +strings sequences namespaces math parser sequences vectors +io.binary hashtables symbols ; IN: crypto.sha1 ! Implemented according to RFC 3174. @@ -107,15 +107,22 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ; : stream>sha1 ( stream -- sha1 ) - [ [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ] with-scope ; + [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ; -: string>sha1 ( string -- sha1 ) stream>sha1 ; -: string>sha1str ( string -- str ) string>sha1 hex-string ; -: string>sha1-bignum ( string -- n ) string>sha1 be> ; -: file>sha1 ( file -- sha1 ) binary stream>sha1 ; +: byte-array>sha1 ( string -- sha1 ) + binary stream>sha1 ; -: string>sha1-interleave ( string -- seq ) +: byte-array>sha1str ( string -- str ) + byte-array>sha1 hex-string ; + +: byte-array>sha1-bignum ( string -- n ) + byte-array>sha1 be> ; + +: file>sha1 ( file -- sha1 ) + binary stream>sha1 ; + +: byte-array>sha1-interleave ( string -- seq ) [ zero? ] left-trim dup length odd? [ 1 tail ] when - seq>2seq [ string>sha1 ] 2apply + seq>2seq [ byte-array>sha1 ] 2apply swap 2seq>seq ; diff --git a/extra/crypto/sha2/sha2-tests.factor b/extra/crypto/sha2/sha2-tests.factor old mode 100644 new mode 100755 index 25da4e1446..8fe655f205 --- a/extra/crypto/sha2/sha2-tests.factor +++ b/extra/crypto/sha2/sha2-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ; -[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" string>sha-256-string ] unit-test -[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" string>sha-256-string ] unit-test -[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" string>sha-256-string ] unit-test -[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" string>sha-256-string ] unit-test -[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>sha-256-string ] unit-test -[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>sha-256-string ] unit-test +[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test +[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test +[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test +[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test +[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test +[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor old mode 100644 new mode 100755 index 6935db82a9..daba6d29ff --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -108,25 +108,25 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ; T1 T2 update-vars ] with each vars get H get [ w+ ] 2map H set ; -: seq>string ( n seq -- string ) - [ swap [ >be % ] curry each ] "" make ; +: seq>byte-array ( n seq -- string ) + [ swap [ >be % ] curry each ] B{ } make ; -: string>sha2 ( string -- string ) +: byte-array>sha2 ( byte-array -- string ) t preprocess-plaintext block-size get group [ process-chunk ] each - 4 H get seq>string ; + 4 H get seq>byte-array ; PRIVATE> -: string>sha-256 ( string -- string ) +: byte-array>sha-256 ( string -- string ) [ K-256 K set initial-H-256 H set 4 word-size set 64 block-size set \ >32-bit >word set - string>sha2 + byte-array>sha2 ] with-scope ; -: string>sha-256-string ( string -- hexstring ) - string>sha-256 hex-string ; +: byte-array>sha-256-string ( string -- hexstring ) + byte-array>sha-256 hex-string ; diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor old mode 100644 new mode 100755 index 91562e89ff..dc7225514e --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -9,37 +9,37 @@ TUPLE: mysql-statement ; TUPLE: mysql-result-set ; M: mysql-db db-open ( mysql-db -- ) - ; + drop ; M: mysql-db dispose ( mysql-db -- ) mysql-db-handle mysql_close ; -M: mysql-db ( str -- statement ) - ; +M: mysql-db ( str in out -- statement ) + 3drop f ; -M: mysql-db ( str -- statement ) - ; +M: mysql-db ( str in out -- statement ) + 3drop f ; M: mysql-statement prepare-statement ( statement -- ) - ; + drop ; M: mysql-statement bind-statement* ( statement -- ) - ; + drop ; M: mysql-statement query-results ( query -- result-set ) - ; + drop f ; M: mysql-result-set #rows ( result-set -- n ) - ; + drop 0 ; M: mysql-result-set #columns ( result-set -- n ) - ; + drop 0 ; M: mysql-result-set row-column ( result-set n -- obj ) - ; + 2drop f ; -M: mysql-result-set advance-row ( result-set -- ? ) - ; +M: mysql-result-set advance-row ( result-set -- ) + drop ; M: mysql-db begin-transaction ( -- ) ; diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index a1ad007c62..43d8ca21ef 100755 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,13 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 2 } { deploy-io 1 } - { deploy-word-props? f } - { deploy-word-defs? f } - { "stop-after-last-window?" t } - { deploy-ui? t } { deploy-compiler? t } + { deploy-word-defs? f } + { deploy-word-props? f } + { deploy-math? t } { deploy-name "Hello world" } { deploy-c-types? f } + { deploy-ui? t } + { deploy-threads? t } + { deploy-reflection 1 } + { "stop-after-last-window?" t } } diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 40654734fa..e655bf9001 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -1,5 +1,6 @@ USING: io io.files io.streams.string io.encodings.utf8 -http.server.templating.fhtml kernel tools.test sequences ; +http.server.templating.fhtml kernel tools.test sequences +parser ; IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) @@ -14,4 +15,6 @@ IN: http.server.templating.fhtml.tests [ t ] [ "bug" test-template ] unit-test [ t ] [ "stack" test-template ] unit-test -[ ] [ "<%\n%>" parse-template drop ] unit-test +[ + [ ] [ "<%\n%>" parse-template drop ] unit-test +] with-file-vocabs diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor old mode 100644 new mode 100755 index cf069f17aa..dbd05eaf2f --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -1,8 +1,8 @@ -USING: help.markup help.syntax strings alien ; +USING: help.markup help.syntax byte-arrays alien ; IN: io.buffers ARTICLE: "buffers" "Locked I/O buffers" -"I/O buffers are first-in-first-out queues of characters. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends." +"I/O buffers are first-in-first-out queues of bytes. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends." $nl "Buffer words are found in the " { $vocab-link "buffers" } " vocabulary." { $subsection buffer } @@ -23,7 +23,7 @@ $nl { $subsection buffer-until } "Writing to the buffer:" { $subsection extend-buffer } -{ $subsection ch>buffer } +{ $subsection byte>buffer } { $subsection >buffer } { $subsection n>buffer } ; @@ -48,7 +48,7 @@ HELP: buffer-free { $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ; HELP: (buffer>>) -{ $values { "buffer" buffer } { "string" "a string" } } +{ $values { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects the entire contents of the buffer into a string." } ; HELP: buffer-reset @@ -68,15 +68,15 @@ HELP: buffer-end { $description "Outputs the memory address of the current fill-pointer." } ; HELP: (buffer>) -{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" string } } +{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ; HELP: buffer> -{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" "a string" } } +{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ; HELP: buffer>> -{ $values { "buffer" buffer } { "string" "a string" } } +{ $values { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ; HELP: buffer-length @@ -102,11 +102,11 @@ HELP: check-overflow { $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ; HELP: >buffer -{ $values { "string" "a string" } { "buffer" buffer } } +{ $values { "byte-array" byte-array } { "buffer" buffer } } { $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ; -HELP: ch>buffer -{ $values { "ch" "a character" } { "buffer" buffer } } +HELP: byte>buffer +{ $values { "byte" "a byte" } { "buffer" buffer } } { $description "Appends a single byte to a buffer." } ; HELP: n>buffer @@ -123,5 +123,5 @@ HELP: buffer-pop { $description "Outputs the byte at the buffer position and advances the position." } ; HELP: buffer-until -{ $values { "separators" string } { "buffer" buffer } { "string" string } { "separator" "a character or " { $link f } } } -{ $description "Searches the buffer for a character appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ; +{ $values { "separators" "a sequence of bytes" } { "buffer" buffer } { "byte-array" byte-array } { "separator" "a byte or " { $link f } } } +{ $description "Searches the buffer for a byte appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index 2260bf5882..1f3e262fed 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,15 +1,15 @@ IN: io.buffers.tests USING: alien alien.c-types io.buffers kernel kernel.private libc -sequences tools.test namespaces ; +sequences tools.test namespaces byte-arrays strings ; : buffer-set ( string buffer -- ) - 2dup buffer-ptr string>char-memory + over >byte-array over buffer-ptr byte-array>memory >r length r> buffer-reset ; : string>buffer ( string -- buffer ) dup length tuck buffer-set ; -[ "" 65536 ] [ +[ B{ } 65536 ] [ 65536 dup (buffer>>) over buffer-capacity @@ -18,15 +18,15 @@ sequences tools.test namespaces ; [ "hello world" "" ] [ "hello world" string>buffer - dup (buffer>>) + dup (buffer>>) >string 0 pick buffer-reset - over (buffer>>) + over (buffer>>) >string rot buffer-free ] unit-test [ "hello" ] [ "hello world" string>buffer - 5 over buffer> swap buffer-free + 5 over buffer> >string swap buffer-free ] unit-test [ 11 ] [ @@ -36,8 +36,8 @@ sequences tools.test namespaces ; [ "hello world" ] [ "hello" 1024 [ buffer-set ] keep - " world" over >buffer - dup (buffer>>) swap buffer-free + " world" >byte-array over >buffer + dup (buffer>>) >string swap buffer-free ] unit-test [ CHAR: e ] [ @@ -47,33 +47,33 @@ sequences tools.test namespaces ; [ "hello" CHAR: \r ] [ "hello\rworld" string>buffer - "\r" over buffer-until + "\r" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello" CHAR: \r ] [ "hello\rworld" string>buffer - "\n\r" over buffer-until + "\n\r" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello\rworld" f ] [ "hello\rworld" string>buffer - "X" over buffer-until + "X" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello" CHAR: \r "world" CHAR: \n ] [ "hello\rworld\n" string>buffer - [ "\r\n" swap buffer-until ] keep - [ "\r\n" swap buffer-until ] keep + [ "\r\n" swap buffer-until >r >string r> ] keep + [ "\r\n" swap buffer-until >r >string r> ] keep buffer-free ] unit-test "hello world" string>buffer "b" set -[ "hello world" ] [ 1000 "b" get buffer> ] unit-test +[ "hello world" ] [ 1000 "b" get buffer> >string ] unit-test "b" get buffer-free 100 "b" set -[ 1000 "b" get n>buffer ] must-fail +[ 1000 "b" get n>buffer >string ] must-fail "b" get buffer-free diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index 6420eb9cbc..a2ecfe3f3e 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -90,7 +90,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; [ buffer-end byte-array>memory ] 2keep [ buffer-fill swap length + ] keep set-buffer-fill ; -: ch>buffer ( ch buffer -- ) +: byte>buffer ( ch buffer -- ) 1 over check-overflow [ buffer-end 0 set-alien-unsigned-1 ] keep [ buffer-fill 1+ ] keep set-buffer-fill ; diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor index d8d2cf5479..e1cb6425ff 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -1,5 +1,5 @@ USING: io io.buffers io.backend help.markup help.syntax kernel -strings sbufs words continuations ; +byte-arrays sbufs words continuations byte-vectors ; IN: io.nonblocking ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" @@ -93,12 +93,12 @@ HELP: unless-eof { $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ; HELP: read-until-step -{ $values { "separators" string } { "port" input-port } { "string/f" "a string or " { $link f } } { "separator/f" "a character or " { $link f } } } +{ $values { "separators" "a sequence of bytes" } { "port" input-port } { "byte-array/f" "a byte array or " { $link f } } { "separator/f" "a byte or " { $link f } } } { $description "If the port has reached end of file, outputs " { $link f } { $link f } ", otherwise scans the buffer for a separator and outputs a string up to but not including the separator." } ; HELP: read-until-loop -{ $values { "seps" string } { "port" input-port } { "sbuf" sbuf } { "separator/f" "a character or " { $link f } } } -{ $description "Accumulates data in the string buffer, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ; +{ $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte or " { $link f } } } +{ $description "Accumulates data in the byte vector, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ; HELP: can-write? { $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } } diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 6eee3739d9..1cd8658355 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -75,7 +75,7 @@ M: input-port stream-read1 [ wait-to-read ] 2keep [ dupd buffer> ] unless-eof nip ; -: read-loop ( count port sbuf -- ) +: read-loop ( count port accum -- ) pick over length - dup 0 > [ pick read-step dup [ over push-all read-loop @@ -143,7 +143,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f ) tuck can-write? [ drop ] [ stream-flush ] if ; M: output-port stream-write1 - 1 over wait-to-write ch>buffer ; + 1 over wait-to-write byte>buffer ; M: output-port stream-write over length over buffer-size > [ diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index d14dff8c22..83e062c3a9 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations io.monitors io.monitors.private io.nonblocking io.buffers io.files io.timeouts io sequences hashtables sorting arrays -combinators math.bitfields ; +combinators math.bitfields strings ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) @@ -66,6 +66,9 @@ M: windows-nt-io ( path recursive? -- monitor ) { [ t ] [ +modify-file+ ] } } cond nip ; +: memory>u16-string ( alien len -- string ) + [ memory>byte-array ] keep 2/ c-ushort-array> >string ; + : parse-file-notify ( buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName diff --git a/extra/koszul/koszul-tests.factor b/extra/koszul/koszul-tests.factor old mode 100644 new mode 100755 index 13dc341350..01fba49995 --- a/extra/koszul/koszul-tests.factor +++ b/extra/koszul/koszul-tests.factor @@ -1,4 +1,5 @@ -USING: koszul tools.test kernel sequences assocs namespaces ; +USING: koszul tools.test kernel sequences assocs namespaces +symbols ; IN: koszul.tests [ diff --git a/extra/serialize/serialize-docs.factor b/extra/serialize/serialize-docs.factor old mode 100644 new mode 100755 index e12751d6ab..e5d4e0602e --- a/extra/serialize/serialize-docs.factor +++ b/extra/serialize/serialize-docs.factor @@ -8,7 +8,7 @@ HELP: (serialize) } { $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } { $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } + { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } } { $see-also deserialize (deserialize) serialize with-serialized } ; @@ -17,7 +17,7 @@ HELP: (deserialize) } { $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } { $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } + { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } } { $see-also (serialize) deserialize serialize with-serialized } ; @@ -26,7 +26,7 @@ HELP: with-serialized } { $description "Creates a scope for serialization and deserialization operations. The quotation is called within this scope. The scope is used for maintaining the structure and object references of serialized objects." } { $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } + { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } } { $see-also (serialize) (deserialize) serialize deserialize } ; @@ -35,7 +35,7 @@ HELP: serialize } { $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." } { $examples - { $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" } + { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } { $see-also deserialize (deserialize) (serialize) with-serialized } ; @@ -44,6 +44,6 @@ HELP: deserialize } { $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." } { $examples - { $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" } + { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } { $see-also (serialize) deserialize (deserialize) with-serialized } ; diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 766103e4b0..93858c7fca 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -1,11 +1,29 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: tools.test kernel serialize io io.streams.string math +USING: tools.test kernel serialize io io.streams.byte-array math alien arrays byte-arrays sequences math prettyprint parser -classes math.constants ; +classes math.constants io.encodings.binary random +combinators.lib ; IN: serialize.tests +: test-serialize-cell + 2^ random dup + binary [ serialize-cell ] with-byte-writer + binary [ deserialize-cell ] with-byte-reader = ; + +[ t ] [ + 100 [ + drop + { + [ 40 [ test-serialize-cell ] all? ] + [ 4 [ 40 * test-serialize-cell ] all? ] + [ 4 [ 400 * test-serialize-cell ] all? ] + [ 4 [ 4000 * test-serialize-cell ] all? ] + } && + ] all? +] unit-test + TUPLE: serialize-test a b ; C: serialize-test @@ -25,6 +43,7 @@ C: serialize-test { 1 2 "three" } V{ 1 2 "three" } SBUF" hello world" + "hello \u123456 unicode" \ dup [ \ dup dup ] T{ serialize-test f "a" 2 } @@ -38,8 +57,9 @@ C: serialize-test : check-serialize-1 ( obj -- ? ) dup class . - dup [ serialize ] with-string-writer - [ deserialize ] with-string-reader = ; + dup + binary [ serialize ] with-byte-writer + binary [ deserialize ] with-byte-reader = ; : check-serialize-2 ( obj -- ? ) dup number? over wrapper? or [ @@ -47,8 +67,8 @@ C: serialize-test ] [ dup class . dup 2array - [ serialize ] with-string-writer - [ deserialize ] with-string-reader + binary [ serialize ] with-byte-writer + binary [ deserialize ] with-byte-reader first2 eq? ] if ; @@ -59,11 +79,14 @@ C: serialize-test [ t ] [ pi check-serialize-1 ] unit-test [ t ] [ - { 1 2 3 } [ + { 1 2 3 } + binary [ [ dup (serialize) (serialize) ] with-serialized - ] with-string-writer [ - deserialize-sequence all-eq? - ] with-string-reader + ] with-byte-writer + binary [ deserialize-sequence all-eq? ] with-byte-reader ] unit-test + +[ serialize ] must-infer +[ deserialize ] must-infer diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 03e1645870..32ace10842 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -10,7 +10,8 @@ IN: serialize USING: namespaces sequences kernel math io math.functions io.binary strings classes words sbufs tuples arrays vectors byte-arrays bit-arrays quotations hashtables -assocs help.syntax help.markup float-arrays splitting ; +assocs help.syntax help.markup float-arrays splitting +io.encodings.string io.encodings.utf8 combinators ; ! Variable holding a sequence of objects already serialized SYMBOL: serialized @@ -24,106 +25,119 @@ SYMBOL: serialized #! Return the id of an already serialized object serialized get [ eq? ] with find [ drop f ] unless ; -USE: prettyprint - ! Serialize object GENERIC: (serialize) ( obj -- ) -: serialize-cell 8 >be write ; +! Numbers are serialized as follows: +! 0 => B{ 0 } +! 1<=x<=126 => B{ x | 0x80 } +! x>127 => B{ length(x) x[0] x[1] ... } +! x>2^1024 => B{ 0xff length(x) x[0] x[1] ... } +! The last case is needed because a very large number would +! otherwise be confused with a small number. +: serialize-cell ( n -- ) + dup zero? [ drop 0 write1 ] [ + dup HEX: 7e <= [ + HEX: 80 bitor write1 + ] [ + dup log2 8 /i 1+ + dup HEX: 7f >= [ + HEX: ff write1 + dup serialize-cell + ] [ + dup write1 + ] if + >be write + ] if + ] if ; -: deserialize-cell 8 read be> ; +: deserialize-cell ( -- n ) + read1 { + { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] } + { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] } + { [ t ] [ read be> ] } + } cond ; : serialize-shared ( obj quot -- ) >r dup object-id - [ "o" write serialize-cell drop ] r> if* ; inline + [ CHAR: o write1 serialize-cell drop ] r> if* ; inline M: f (serialize) ( obj -- ) - drop "n" write ; - -: bytes-needed ( number -- int ) - log2 8 + 8 /i ; inline + drop CHAR: n write1 ; M: integer (serialize) ( obj -- ) - dup 0 = [ - drop "z" write + dup zero? [ + drop CHAR: z write1 ] [ - dup 0 < [ neg "m" ] [ "p" ] if write - dup bytes-needed dup serialize-cell - >be write + dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1 + serialize-cell ] if ; M: float (serialize) ( obj -- ) - "F" write + CHAR: F write1 double>bits serialize-cell ; M: complex (serialize) ( obj -- ) - "c" write + CHAR: c write1 dup real-part (serialize) imaginary-part (serialize) ; M: ratio (serialize) ( obj -- ) - "r" write + CHAR: r write1 dup numerator (serialize) denominator (serialize) ; -M: string (serialize) ( obj -- ) - [ - "s" write - dup add-object serialize-cell - dup length serialize-cell - write - ] serialize-shared ; +: serialize-string ( obj code -- ) + write1 + dup add-object serialize-cell + utf8 encode + dup length serialize-cell + write ; -M: sbuf (serialize) ( obj -- ) - [ - "S" write - dup add-object serialize-cell - dup length serialize-cell - >string write - ] serialize-shared ; +M: string (serialize) ( obj -- ) + [ CHAR: s serialize-string ] serialize-shared ; + +: serialize-elements + [ (serialize) ] each CHAR: . write1 ; M: tuple (serialize) ( obj -- ) [ - "T" write + CHAR: T write1 dup add-object serialize-cell - tuple>array - dup length serialize-cell - [ (serialize) ] each + tuple>array serialize-elements ] serialize-shared ; : serialize-seq ( seq code -- ) [ - write + write1 dup add-object serialize-cell - dup length serialize-cell - [ (serialize) ] each + serialize-elements ] curry serialize-shared ; M: array (serialize) ( obj -- ) - "a" serialize-seq ; - -M: vector (serialize) ( obj -- ) - "v" serialize-seq ; + CHAR: a serialize-seq ; M: byte-array (serialize) ( obj -- ) - "A" serialize-seq ; + [ + CHAR: A write1 + dup add-object serialize-cell + dup length serialize-cell write + ] serialize-shared ; M: bit-array (serialize) ( obj -- ) - "b" serialize-seq ; + [ + CHAR: b write1 + dup add-object serialize-cell + dup length serialize-cell + [ 1 0 ? ] B{ } map-as write + ] serialize-shared ; M: quotation (serialize) ( obj -- ) - "q" serialize-seq ; - -M: curry (serialize) ( obj -- ) - [ - "C" write - dup add-object serialize-cell - dup curry-obj (serialize) curry-quot (serialize) - ] serialize-shared ; + CHAR: q serialize-seq ; M: float-array (serialize) ( obj -- ) [ - "f" write + CHAR: f write1 dup add-object serialize-cell dup length serialize-cell [ double>bits 8 >be write ] each @@ -131,18 +145,18 @@ M: float-array (serialize) ( obj -- ) M: hashtable (serialize) ( obj -- ) [ - "h" write + CHAR: h write1 dup add-object serialize-cell >alist (serialize) ] serialize-shared ; M: word (serialize) ( obj -- ) - "w" write + CHAR: w write1 dup word-name (serialize) word-vocabulary (serialize) ; M: wrapper (serialize) ( obj -- ) - "W" write + CHAR: W write1 wrapped (serialize) ; DEFER: (deserialize) ( -- obj ) @@ -154,7 +168,7 @@ DEFER: (deserialize) ( -- obj ) f ; : deserialize-positive-integer ( -- number ) - deserialize-cell read be> ; + deserialize-cell ; : deserialize-negative-integer ( -- number ) deserialize-positive-integer neg ; @@ -171,11 +185,11 @@ DEFER: (deserialize) ( -- obj ) : deserialize-complex ( -- complex ) (deserialize) (deserialize) rect> ; -: deserialize-string ( -- string ) - deserialize-cell deserialize-cell read intern-object ; +: (deserialize-string) ( -- string ) + deserialize-cell read utf8 decode ; -: deserialize-sbuf ( -- sbuf ) - deserialize-cell deserialize-cell read >sbuf intern-object ; +: deserialize-string ( -- string ) + deserialize-cell (deserialize-string) intern-object ; : deserialize-word ( -- word ) (deserialize) dup (deserialize) lookup @@ -184,25 +198,30 @@ DEFER: (deserialize) ( -- obj ) : deserialize-wrapper ( -- wrapper ) (deserialize) ; +SYMBOL: +stop+ + +: (deserialize-seq) + [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ; + : deserialize-seq ( seq -- array ) - deserialize-cell deserialize-cell - [ drop (deserialize) ] roll map-as - intern-object ; + >r deserialize-cell (deserialize-seq) r> like intern-object ; : deserialize-array ( -- array ) { } deserialize-seq ; -: deserialize-vector ( -- array ) - V{ } deserialize-seq ; - : deserialize-quotation ( -- array ) [ ] deserialize-seq ; +: (deserialize-byte-array) ( -- byte-array ) + deserialize-cell read B{ } like ; + : deserialize-byte-array ( -- byte-array ) - B{ } deserialize-seq ; + deserialize-cell (deserialize-byte-array) intern-object ; : deserialize-bit-array ( -- bit-array ) - ?{ } deserialize-seq ; + deserialize-cell + (deserialize-byte-array) [ 0 > ] ?{ } map-as + intern-object ; : deserialize-float-array ( -- float-array ) deserialize-cell deserialize-cell @@ -213,43 +232,37 @@ DEFER: (deserialize) ( -- obj ) deserialize-cell (deserialize) >hashtable intern-object ; : deserialize-tuple ( -- array ) - deserialize-cell - deserialize-cell [ drop (deserialize) ] map >tuple - intern-object ; - -: deserialize-curry ( -- curry ) - deserialize-cell - (deserialize) (deserialize) curry - intern-object ; + deserialize-cell (deserialize-seq) >tuple intern-object ; : deserialize-unknown ( -- object ) deserialize-cell serialized get nth ; +: deserialize-stop ( -- object ) + +stop+ get ; + : deserialize* ( -- object ? ) read1 [ - H{ - { CHAR: A deserialize-byte-array } - { CHAR: C deserialize-curry } - { CHAR: F deserialize-float } - { CHAR: S deserialize-sbuf } - { CHAR: T deserialize-tuple } - { CHAR: W deserialize-wrapper } - { CHAR: a deserialize-array } - { CHAR: b deserialize-bit-array } - { CHAR: c deserialize-complex } - { CHAR: f deserialize-float-array } - { CHAR: h deserialize-hashtable } - { CHAR: m deserialize-negative-integer } - { CHAR: n deserialize-false } - { CHAR: o deserialize-unknown } - { CHAR: p deserialize-positive-integer } - { CHAR: q deserialize-quotation } - { CHAR: r deserialize-ratio } - { CHAR: s deserialize-string } - { CHAR: v deserialize-vector } - { CHAR: w deserialize-word } - { CHAR: z deserialize-zero } - } at dup [ "Unknown typecode" throw ] unless execute t + { + { CHAR: A [ deserialize-byte-array ] } + { CHAR: F [ deserialize-float ] } + { CHAR: T [ deserialize-tuple ] } + { CHAR: W [ deserialize-wrapper ] } + { CHAR: a [ deserialize-array ] } + { CHAR: b [ deserialize-bit-array ] } + { CHAR: c [ deserialize-complex ] } + { CHAR: f [ deserialize-float-array ] } + { CHAR: h [ deserialize-hashtable ] } + { CHAR: m [ deserialize-negative-integer ] } + { CHAR: n [ deserialize-false ] } + { CHAR: o [ deserialize-unknown ] } + { CHAR: p [ deserialize-positive-integer ] } + { CHAR: q [ deserialize-quotation ] } + { CHAR: r [ deserialize-ratio ] } + { CHAR: s [ deserialize-string ] } + { CHAR: w [ deserialize-word ] } + { CHAR: z [ deserialize-zero ] } + { CHAR: . [ deserialize-stop ] } + } case t ] [ f f ] if* ; @@ -258,7 +271,11 @@ DEFER: (deserialize) ( -- obj ) deserialize* [ "End of stream" throw ] unless ; : with-serialized ( quot -- ) - V{ } clone serialized rot with-variable ; inline + [ + V{ } clone serialized set + gensym +stop+ set + call + ] with-scope ; inline : deserialize-sequence ( -- seq ) [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ; From 4b4f3b8ea98b3566a102333c2abf72e7b57a2ddf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Mar 2008 03:50:03 -0600 Subject: [PATCH 54/63] Faster serialization --- .../server/authentication/basic/basic.factor | 50 -------- extra/serialize/serialize-docs.factor | 31 +---- extra/serialize/serialize-tests.factor | 11 -- extra/serialize/serialize.factor | 107 ++++++++++-------- 4 files changed, 59 insertions(+), 140 deletions(-) delete mode 100755 extra/http/server/authentication/basic/basic.factor diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor deleted file mode 100755 index b6dbed4b62..0000000000 --- a/extra/http/server/authentication/basic/basic.factor +++ /dev/null @@ -1,50 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -IN: http.server.authentication.basic -USING: accessors new-slots quotations assocs kernel splitting -base64 crypto.sha2 html.elements io combinators http.server -http sequences ; - -! 'users' is a quotation or an assoc. The quotation -! has stack effect ( sha-256-string username -- ? ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'users' is an assoc then -! it is a mapping of usernames to sha-256 hashed passwords. -TUPLE: realm responder name users ; - -C: realm - -: user-authorized? ( password username realm -- ? ) - users>> { - { [ dup callable? ] [ call ] } - { [ dup assoc? ] [ at = ] } - } cond ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split1 swap "Basic" = [ - base64> ":" split1 string>sha-256-string - spin user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: <401> ( realm -- response ) - 401 "Unauthorized" - "Basic realm=\"" rot name>> "\"" 3append - "WWW-Authenticate" set-header - [ - - "Username or Password is invalid" write - - ] >>body ; - -M: realm call-responder ( request path realm -- response ) - pick "authorization" header dupd authorization-ok? - [ responder>> call-responder ] [ 2nip <401> ] if ; diff --git a/extra/serialize/serialize-docs.factor b/extra/serialize/serialize-docs.factor index e5d4e0602e..6b2dd304f5 100755 --- a/extra/serialize/serialize-docs.factor +++ b/extra/serialize/serialize-docs.factor @@ -3,33 +3,6 @@ USING: help.syntax help.markup ; IN: serialize -HELP: (serialize) -{ $values { "obj" "object to serialize" } -} -{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } -{ $examples - { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } -} -{ $see-also deserialize (deserialize) serialize with-serialized } ; - -HELP: (deserialize) -{ $values { "obj" "deserialized object" } -} -{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } -{ $examples - { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } -} -{ $see-also (serialize) deserialize serialize with-serialized } ; - -HELP: with-serialized -{ $values { "quot" "a quotation" } -} -{ $description "Creates a scope for serialization and deserialization operations. The quotation is called within this scope. The scope is used for maintaining the structure and object references of serialized objects." } -{ $examples - { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } -} -{ $see-also (serialize) (deserialize) serialize deserialize } ; - HELP: serialize { $values { "obj" "object to serialize" } } @@ -37,7 +10,7 @@ HELP: serialize { $examples { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } -{ $see-also deserialize (deserialize) (serialize) with-serialized } ; +{ $see-also deserialize } ; HELP: deserialize { $values { "obj" "deserialized object" } @@ -46,4 +19,4 @@ HELP: deserialize { $examples { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } -{ $see-also (serialize) deserialize (deserialize) with-serialized } ; +{ $see-also serialize } ; diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 93858c7fca..1831495924 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -77,16 +77,5 @@ C: serialize-test [ t ] [ objects [ check-serialize-2 ] all? ] unit-test [ t ] [ pi check-serialize-1 ] unit-test - -[ t ] [ - { 1 2 3 } - binary [ - [ - dup (serialize) (serialize) - ] with-serialized - ] with-byte-writer - binary [ deserialize-sequence all-eq? ] with-byte-reader -] unit-test - [ serialize ] must-infer [ deserialize ] must-infer diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 32ace10842..36455bd060 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -13,17 +13,25 @@ vectors byte-arrays bit-arrays quotations hashtables assocs help.syntax help.markup float-arrays splitting io.encodings.string io.encodings.utf8 combinators ; -! Variable holding a sequence of objects already serialized +! Variable holding a assoc of objects already serialized SYMBOL: serialized -: add-object ( obj -- id ) +TUPLE: id obj ; + +C: id + +M: id hashcode* id-obj hashcode* ; + +M: id equal? over id? [ [ id-obj ] 2apply eq? ] [ 2drop f ] if ; + +: add-object ( obj -- ) #! Add an object to the sequence of already serialized - #! objects. Return the id of that object. - serialized get [ push ] keep length 1 - ; + #! objects. + serialized get [ assoc-size swap ] keep set-at ; : object-id ( obj -- id ) #! Return the id of an already serialized object - serialized get [ eq? ] with find [ drop f ] unless ; + serialized get at ; ! Serialize object GENERIC: (serialize) ( obj -- ) @@ -89,10 +97,8 @@ M: ratio (serialize) ( obj -- ) : serialize-string ( obj code -- ) write1 - dup add-object serialize-cell - utf8 encode - dup length serialize-cell - write ; + dup utf8 encode dup length serialize-cell write + add-object ; M: string (serialize) ( obj -- ) [ CHAR: s serialize-string ] serialize-shared ; @@ -103,15 +109,15 @@ M: string (serialize) ( obj -- ) M: tuple (serialize) ( obj -- ) [ CHAR: T write1 - dup add-object serialize-cell - tuple>array serialize-elements + dup tuple>array serialize-elements + add-object ] serialize-shared ; : serialize-seq ( seq code -- ) [ write1 - dup add-object serialize-cell - serialize-elements + dup serialize-elements + add-object ] curry serialize-shared ; M: array (serialize) ( obj -- ) @@ -120,16 +126,16 @@ M: array (serialize) ( obj -- ) M: byte-array (serialize) ( obj -- ) [ CHAR: A write1 - dup add-object serialize-cell - dup length serialize-cell write + dup dup length serialize-cell write + add-object ] serialize-shared ; M: bit-array (serialize) ( obj -- ) [ CHAR: b write1 - dup add-object serialize-cell dup length serialize-cell - [ 1 0 ? ] B{ } map-as write + dup [ 1 0 ? ] B{ } map-as write + add-object ] serialize-shared ; M: quotation (serialize) ( obj -- ) @@ -138,22 +144,25 @@ M: quotation (serialize) ( obj -- ) M: float-array (serialize) ( obj -- ) [ CHAR: f write1 - dup add-object serialize-cell dup length serialize-cell - [ double>bits 8 >be write ] each + dup [ double>bits 8 >be write ] each + add-object ] serialize-shared ; M: hashtable (serialize) ( obj -- ) [ CHAR: h write1 - dup add-object serialize-cell - >alist (serialize) + dup >alist (serialize) + add-object ] serialize-shared ; M: word (serialize) ( obj -- ) - CHAR: w write1 - dup word-name (serialize) - word-vocabulary (serialize) ; + [ + CHAR: w write1 + dup word-name (serialize) + dup word-vocabulary (serialize) + add-object + ] serialize-shared ; M: wrapper (serialize) ( obj -- ) CHAR: W write1 @@ -161,8 +170,10 @@ M: wrapper (serialize) ( obj -- ) DEFER: (deserialize) ( -- obj ) -: intern-object ( id obj -- obj ) - dup rot serialized get set-nth ; +SYMBOL: deserialized + +: intern-object ( obj -- ) + deserialized get push ; : deserialize-false ( -- f ) f ; @@ -189,22 +200,22 @@ DEFER: (deserialize) ( -- obj ) deserialize-cell read utf8 decode ; : deserialize-string ( -- string ) - deserialize-cell (deserialize-string) intern-object ; + (deserialize-string) dup intern-object ; : deserialize-word ( -- word ) (deserialize) dup (deserialize) lookup - [ ] [ "Unknown word" throw ] ?if ; + [ dup intern-object ] [ "Unknown word" throw ] ?if ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; SYMBOL: +stop+ -: (deserialize-seq) +: (deserialize-seq) ( -- seq ) [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ; : deserialize-seq ( seq -- array ) - >r deserialize-cell (deserialize-seq) r> like intern-object ; + >r (deserialize-seq) r> like dup intern-object ; : deserialize-array ( -- array ) { } deserialize-seq ; @@ -216,26 +227,25 @@ SYMBOL: +stop+ deserialize-cell read B{ } like ; : deserialize-byte-array ( -- byte-array ) - deserialize-cell (deserialize-byte-array) intern-object ; + (deserialize-byte-array) dup intern-object ; : deserialize-bit-array ( -- bit-array ) - deserialize-cell (deserialize-byte-array) [ 0 > ] ?{ } map-as - intern-object ; + dup intern-object ; : deserialize-float-array ( -- float-array ) - deserialize-cell deserialize-cell + deserialize-cell 8 * read 8 [ be> bits>double ] F{ } map-as - intern-object ; + dup intern-object ; : deserialize-hashtable ( -- hashtable ) - deserialize-cell (deserialize) >hashtable intern-object ; + (deserialize) >hashtable dup intern-object ; : deserialize-tuple ( -- array ) - deserialize-cell (deserialize-seq) >tuple intern-object ; + (deserialize-seq) >tuple dup intern-object ; : deserialize-unknown ( -- object ) - deserialize-cell serialized get nth ; + deserialize-cell deserialized get nth ; : deserialize-stop ( -- object ) +stop+ get ; @@ -270,18 +280,15 @@ SYMBOL: +stop+ : (deserialize) ( -- obj ) deserialize* [ "End of stream" throw ] unless ; -: with-serialized ( quot -- ) - [ - V{ } clone serialized set - gensym +stop+ set - call - ] with-scope ; inline - -: deserialize-sequence ( -- seq ) - [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ; - : deserialize ( -- obj ) - [ (deserialize) ] with-serialized ; + [ + V{ } clone deserialized set + gensym +stop+ set + (deserialize) + ] with-scope ; : serialize ( obj -- ) - [ (serialize) ] with-serialized ; \ No newline at end of file + [ + H{ } clone serialized set + (serialize) + ] with-scope ; \ No newline at end of file From 09352a93275b880b633fcbe353475f5f8d902e14 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Mar 2008 04:01:43 -0600 Subject: [PATCH 55/63] Cleanup --- extra/db/sqlite/lib/lib.factor | 8 ++++---- extra/db/types/types.factor | 3 +-- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index f11f1e2ba6..9bf9ede895 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -3,8 +3,7 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize -io.streams.string byte-arrays ; -USE: tools.walker +io.streams.byte-array byte-arrays io.encodings.binary ; IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -94,7 +93,7 @@ IN: db.sqlite.lib { TIMESTAMP [ sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ - [ serialize ] with-string-writer >byte-array + binary [ serialize ] with-byte-writer sqlite-bind-blob-by-name ] } { +native-id+ [ sqlite-bind-int-by-name ] } @@ -137,7 +136,8 @@ IN: db.sqlite.lib { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } { BLOB [ sqlite-column-blob ] } { FACTOR-BLOB [ - sqlite-column-blob [ deserialize ] with-string-reader + sqlite-column-blob + binary [ deserialize ] with-byte-reader ] } ! { NULL [ 2drop f ] } [ no-sql-type ] diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index c6d11281a1..7014aaa943 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,8 +3,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes -mirrors tuples combinators calendar.format serialize -io.streams.string symbols ; +mirrors tuples combinators calendar.format symbols ; IN: db.types HOOK: modifier-table db ( -- hash ) From 26df05b91264fcb4b83b390b4585eb905ec2282d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Mar 2008 04:27:19 -0600 Subject: [PATCH 56/63] More unit test fixes --- core/io/encodings/utf8/utf8-tests.factor | 1 + extra/bitfields/bitfields-tests.factor | 1 + extra/calendar/calendar-tests.factor | 1 + extra/db/sqlite/sqlite.factor | 9 +--- extra/hash2/hash2-tests.factor | 1 + extra/ldap/ldap-tests.factor | 57 ++++++++++---------- extra/multiline/multiline-tests.factor | 1 + extra/pdf/pdf-tests.factor | 1 + extra/rss/rss-tests.factor | 1 + extra/sequences/deep/deep-tests.factor | 1 + extra/tuple-arrays/tuple-arrays-tests.factor | 1 + extra/xml/tests/errors.factor | 1 + extra/xmode/tokens/tokens.factor | 12 ++--- 13 files changed, 47 insertions(+), 41 deletions(-) mode change 100644 => 100755 extra/bitfields/bitfields-tests.factor mode change 100644 => 100755 extra/hash2/hash2-tests.factor mode change 100644 => 100755 extra/ldap/ldap-tests.factor mode change 100644 => 100755 extra/multiline/multiline-tests.factor mode change 100644 => 100755 extra/pdf/pdf-tests.factor mode change 100644 => 100755 extra/rss/rss-tests.factor mode change 100644 => 100755 extra/sequences/deep/deep-tests.factor mode change 100644 => 100755 extra/tuple-arrays/tuple-arrays-tests.factor mode change 100644 => 100755 extra/xml/tests/errors.factor mode change 100644 => 100755 extra/xmode/tokens/tokens.factor diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index 25eae5ae22..af169854c9 100755 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,4 +1,5 @@ USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ; +IN: io.encodings.utf8.tests : decode-utf8-w/stream ( array -- newarray ) utf8 decode >array ; diff --git a/extra/bitfields/bitfields-tests.factor b/extra/bitfields/bitfields-tests.factor old mode 100644 new mode 100755 index 8a3bb1f043..bbd4aa3db0 --- a/extra/bitfields/bitfields-tests.factor +++ b/extra/bitfields/bitfields-tests.factor @@ -1,4 +1,5 @@ USING: tools.test bitfields kernel ; +IN: bitfields.tests SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ; diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index f700d244f5..1041c79691 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,5 +1,6 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; +IN: calendar.tests [ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test [ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 2fb62bf656..b72d788605 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays assocs classes compiler db -hashtables io.files io.files.tmp kernel math math.parser namespaces +hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types combinators tools.walker +words combinators.lib db.types combinators combinators.cleave io namespaces.lib ; IN: db.sqlite @@ -25,11 +25,6 @@ M: sqlite-db dispose ( db -- ) dispose-db ; : with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline -: with-tmp-sqlite ( quot -- ) - ".db" [ - swap with-sqlite - ] with-tmpfile ; - TUPLE: sqlite-statement ; TUPLE: sqlite-result-set has-more? ; diff --git a/extra/hash2/hash2-tests.factor b/extra/hash2/hash2-tests.factor old mode 100644 new mode 100755 index b7a4f42ac5..f3c17bb04b --- a/extra/hash2/hash2-tests.factor +++ b/extra/hash2/hash2-tests.factor @@ -1,4 +1,5 @@ USING: tools.test hash2 kernel ; +IN: hash2.tests : sample-hash 5 diff --git a/extra/ldap/ldap-tests.factor b/extra/ldap/ldap-tests.factor old mode 100644 new mode 100755 index 42e51c782a..14029706e5 --- a/extra/ldap/ldap-tests.factor +++ b/extra/ldap/ldap-tests.factor @@ -1,57 +1,58 @@ -USING: alien alien.c-types io kernel ldap ldap.libldap namespaces prettyprint -tools.test ; +USING: alien alien.c-types io kernel ldap ldap.libldap +namespaces prettyprint tools.test ; +IN: ldap.tests "void*" "ldap://localhost:389" initialize get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 set-option -[ 3 ] [ +[ 3 ] [ get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" [ get-option ] keep *int ] unit-test [ -get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ + get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ - ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 - ! "void*" [ search-s ] keep *int . + ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 + ! "void*" [ search-s ] keep *int . - [ 2 ] [ - get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0 - search - ] unit-test + [ 2 ] [ + get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0 + search + ] unit-test - ! get-ldp LDAP_RES_ANY 0 f "void*" result . + ! get-ldp LDAP_RES_ANY 0 f "void*" result . - get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" result + get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" result - ! get-message *int . + ! get-message *int . - "Message ID: " write + "Message ID: " write - get-message msgid . + get-message msgid . - get-ldp get-message get-dn . + get-ldp get-message get-dn . - "Entries count: " write + "Entries count: " write - get-ldp get-message count-entries . + get-ldp get-message count-entries . - SYMBOL: entry - SYMBOL: attr + SYMBOL: entry + SYMBOL: attr - "Attribute: " write + "Attribute: " write - get-ldp get-message first-entry entry set get-ldp entry get - "void*" first-attribute dup . attr set + get-ldp get-message first-entry entry set get-ldp entry get + "void*" first-attribute dup . attr set - "Value: " write + "Value: " write - get-ldp entry get attr get get-values *char* . + get-ldp entry get attr get get-values *char* . - get-ldp get-message first-message msgtype result-type + get-ldp get-message first-message msgtype result-type - get-ldp get-message next-message msgtype result-type + get-ldp get-message next-message msgtype result-type -] with-bind + ] with-bind ] drop diff --git a/extra/multiline/multiline-tests.factor b/extra/multiline/multiline-tests.factor old mode 100644 new mode 100755 index a9b9ee2322..c323e9b96a --- a/extra/multiline/multiline-tests.factor +++ b/extra/multiline/multiline-tests.factor @@ -1,4 +1,5 @@ USING: multiline tools.test ; +IN: multiline.tests STRING: test-it foo diff --git a/extra/pdf/pdf-tests.factor b/extra/pdf/pdf-tests.factor old mode 100644 new mode 100755 index 097f671d9a..290773a89d --- a/extra/pdf/pdf-tests.factor +++ b/extra/pdf/pdf-tests.factor @@ -1,4 +1,5 @@ USING: io.files kernel math namespaces pdf pdf.libhpdf prettyprint sequences ; +IN: pdf.tests SYMBOL: font diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor old mode 100644 new mode 100755 index 1d493d3c14..77364d73e7 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -1,4 +1,5 @@ USING: rss io kernel io.files tools.test io.encodings.utf8 ; +IN: rss.tests : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor old mode 100644 new mode 100755 index 9c02d52089..541570f3f9 --- a/extra/sequences/deep/deep-tests.factor +++ b/extra/sequences/deep/deep-tests.factor @@ -1,5 +1,6 @@ USING: sequences.deep kernel tools.test strings math arrays namespaces sequences ; +IN: sequences.deep.tests [ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor old mode 100644 new mode 100755 index dfe9002bb9..dd9510405f --- a/extra/tuple-arrays/tuple-arrays-tests.factor +++ b/extra/tuple-arrays/tuple-arrays-tests.factor @@ -1,4 +1,5 @@ USING: tuple-arrays sequences tools.test namespaces kernel math ; +IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; diff --git a/extra/xml/tests/errors.factor b/extra/xml/tests/errors.factor old mode 100644 new mode 100755 index c0a60d8a3f..b421ae011a --- a/extra/xml/tests/errors.factor +++ b/extra/xml/tests/errors.factor @@ -1,4 +1,5 @@ USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ; +IN: xml.tests : xml-error-test ( expected-error xml-string -- ) [ string>xml ] curry swap [ = ] curry must-fail-with ; diff --git a/extra/xmode/tokens/tokens.factor b/extra/xmode/tokens/tokens.factor old mode 100644 new mode 100755 index e1fa2dd04f..7b913cbac0 --- a/extra/xmode/tokens/tokens.factor +++ b/extra/xmode/tokens/tokens.factor @@ -5,12 +5,12 @@ IN: xmode.tokens ! Based on org.gjt.sp.jedit.syntax.Token SYMBOL: tokens -[ - { "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [ - create-in dup define-symbol - dup word-name swap - ] H{ } map>assoc tokens set-global -] with-compilation-unit +<< +{ "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [ + create-in dup define-symbol + dup word-name swap +] H{ } map>assoc tokens set-global +>> : string>token ( string -- id ) tokens get at ; From 7b409be5928a70e301dd8ec9196b8dfaea01042c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Mar 2008 04:33:02 -0600 Subject: [PATCH 57/63] Disable oracle tests for now --- extra/oracle/oracle-tests.factor | 62 ++++++++++++++++---------------- 1 file changed, 32 insertions(+), 30 deletions(-) mode change 100644 => 100755 extra/oracle/oracle-tests.factor diff --git a/extra/oracle/oracle-tests.factor b/extra/oracle/oracle-tests.factor old mode 100644 new mode 100755 index 5756578d92..7006bde23a --- a/extra/oracle/oracle-tests.factor +++ b/extra/oracle/oracle-tests.factor @@ -1,57 +1,59 @@ USING: oracle oracle.liboci prettyprint tools.test ; -"testuser" "testpassword" "//localhost/test1" log-on . +[ + "testuser" "testpassword" "//localhost/test1" log-on . -allocate-statement-handle + allocate-statement-handle -"CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement + "CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"COMMIT" prepare-statement + "COMMIT" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"SELECT * FROM TESTTABLE" prepare-statement + "SELECT * FROM TESTTABLE" prepare-statement -1 SQLT_STR define-by-position run-query + 1 SQLT_STR define-by-position run-query -[ V{ "hello" "hi" "bye" "50" "60" "70" } ] [ -2 SQLT_STR define-by-position run-query gather-results -] unit-test + [ V{ "hello" "hi" "bye" "50" "60" "70" } ] [ + 2 SQLT_STR define-by-position run-query gather-results + ] unit-test -clear-result + clear-result -"UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement + "UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"COMMIT" prepare-statement + "COMMIT" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement + "SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement -[ V{ "10" } ] [ -2 SQLT_STR define-by-position run-query gather-results -] unit-test + [ V{ "10" } ] [ + 2 SQLT_STR define-by-position run-query gather-results + ] unit-test -clear-result + clear-result -"DROP TABLE TESTTABLE" prepare-statement + "DROP TABLE TESTTABLE" prepare-statement -execute-statement + execute-statement -free-statement-handle log-off clean-up terminate + free-statement-handle log-off clean-up terminate +] drop From d35239bdd4c7c19c2d74c1514b1a27a713e4bc50 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 8 Mar 2008 11:41:49 -0600 Subject: [PATCH 58/63] don't require port on mac if they have git --- misc/factor.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index 3a6d2d64f9..a823bf7b0e 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -95,7 +95,7 @@ check_installed_programs() { ensure_program_installed md5sum md5 ensure_program_installed cut case $OS in - macosx) ensure_program_installed port;; + macosx) ensure_program_installed git port;; netbsd) ensure_program_installed gmake;; esac check_gcc_version From da29219d7b3fe0e87cb54e6ae4c8ae0810471fe0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 8 Mar 2008 11:44:28 -0600 Subject: [PATCH 59/63] better fix for misc/factor.sh --- misc/factor.sh | 1 - 1 file changed, 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index a823bf7b0e..ed2c0ce130 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -95,7 +95,6 @@ check_installed_programs() { ensure_program_installed md5sum md5 ensure_program_installed cut case $OS in - macosx) ensure_program_installed git port;; netbsd) ensure_program_installed gmake;; esac check_gcc_version From 07e89862263294e47f0dc1c3f3614f27fbb3c4df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 8 Mar 2008 12:00:40 -0600 Subject: [PATCH 60/63] fix some issues with the misc/factor.sh script --- misc/factor.sh | 37 ++++++++++++++++++++++++------------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index ed2c0ce130..0ad44430c8 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -68,11 +68,11 @@ check_gcc_version() { } set_downloader() { - test_program_installed wget + test_program_installed wget curl if [[ $? -ne 0 ]] ; then - DOWNLOAD=wget + DOWNLOADER=wget else - DOWNLOAD="curl -O" + DOWNLOADER="curl -O" fi } @@ -202,6 +202,7 @@ echo_build_info() { echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET echo GIT_PROTOCOL=$GIT_PROTOCOL echo GIT_URL=$GIT_URL + echo DOWNLOADER=$DOWNLOADER } set_build_info() { @@ -234,6 +235,7 @@ find_build_info() { find_word_size set_factor_binary set_build_info + set_downloader echo_build_info } @@ -303,12 +305,12 @@ get_boot_image() { } get_url() { - if [[ $DOWNLOAD -eq "" ]] ; then + if [[ $DOWNLOADER -eq "" ]] ; then set_downloader; fi - echo $DOWNLOAD $1 ; - $DOWNLOAD $1 - check_ret $DOWNLOAD + echo $DOWNLOADER $1 ; + $DOWNLOADER $1 + check_ret $DOWNLOADER } maybe_download_dlls() { @@ -371,14 +373,23 @@ make_boot_image() { } -install_libraries_apt() { +install_build_system_apt() { + ensure_program_installed yes yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make check_ret sudo } -install_libraries_port() { - ensure_program_installed port - yes | sudo port install git-core +install_build_system_port() { + test_program_installed git + if [[ $? -ne 1 ]] ; then + ensure_program_installed yes + echo "git not found." + echo "This script requires either git-core or port." + echo "If it fails, install git-core or port and try again." + ensure_program_installed port + echo "Installing git-core with port...this will take awhile." + yes | sudo port install git-core + fi } usage() { @@ -389,8 +400,8 @@ usage() { case "$1" in install) install ;; - install-x11) install_libraries_apt; install ;; - install-macosx) install_libraries_port; install ;; + install-x11) install_build_system_apt; install ;; + install-macosx) install_build_system_port; install ;; self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;; From 3b7d630a84ebc72bcf1805f502059683d8fce472 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 8 Mar 2008 12:01:48 -0600 Subject: [PATCH 61/63] implement CREATE-CLASS with create-class add SINGLETONS: --- core/parser/parser.factor | 7 +++++-- extra/singleton/singleton-docs.factor | 12 ++++++++++++ extra/singleton/singleton.factor | 15 ++++++++++----- 3 files changed, 27 insertions(+), 7 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 8e1927c043..cc84084258 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -240,11 +240,14 @@ PREDICATE: unexpected unexpected-eof : CREATE ( -- word ) scan create-in ; -: CREATE-CLASS ( -- word ) - scan in get create +: create-class ( word vocab -- word ) + create dup save-class-location dup predicate-word dup set-word save-location ; +: CREATE-CLASS ( -- word ) + scan in get create-class ; + : word-restarts ( possibilities -- restarts ) natural-sort [ [ "Use the word " swap summary append ] keep diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor index 4ebbc9b71d..358d1a5bf6 100644 --- a/extra/singleton/singleton-docs.factor +++ b/extra/singleton/singleton-docs.factor @@ -12,3 +12,15 @@ HELP: SINGLETON: } { $see-also POSTPONE: PREDICATE: } ; + +HELP: SINGLETONS: +{ $syntax "SINGLETONS: classes... ;" +} { $values + { "classes" "new singletons to define" } +} { $description + "Defines a new singleton for each class in the list." +} { $examples + { $example "SINGLETONS: foo bar baz ;" "" } +} { $see-also + POSTPONE: SINGLETON: +} ; diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index f859cec5c0..1451283f23 100644 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -1,10 +1,15 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes.predicate kernel parser quotations words ; +USING: classes.predicate kernel namespaces parser quotations +sequences words ; IN: singleton +: define-singleton ( token -- ) + \ word swap in get create-class + dup [ eq? ] curry define-predicate-class ; : SINGLETON: - \ word - CREATE-CLASS - dup [ eq? ] curry define-predicate-class ; parsing + scan define-singleton ; parsing + +: SINGLETONS: + ";" parse-tokens [ define-singleton ] each ; parsing From d7d64b202f19ed6ec9cc4374e8625352b093b520 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 8 Mar 2008 12:02:19 -0600 Subject: [PATCH 62/63] minor cleanup --- extra/db/sql/sql.factor | 5 ++--- extra/db/tuples/tuples.factor | 1 - 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 062eab8bc8..1de4bdfb5a 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -1,7 +1,6 @@ USING: kernel parser quotations tuples words -namespaces.lib namespaces sequences bake arrays combinators -prettyprint strings math.parser new-slots accessors -sequences.lib math symbols ; +namespaces.lib namespaces sequences arrays combinators +prettyprint strings math.parser sequences.lib math symbols ; USE: tools.walker IN: db.sql diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index bc7fcba034..32055ccedc 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -84,7 +84,6 @@ HOOK: insert-tuple* db ( tuple statement -- ) [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - ! break dup class db-columns find-primary-key assigned-id? [ insert-assigned ] [ From 57c772303f73acdb9fedc7d2db497ee3d3ee4e6c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 8 Mar 2008 22:46:57 -0600 Subject: [PATCH 63/63] builder.test: Show tests which fail in addition to vocabularies --- extra/builder/test/test.factor | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index d03be0781a..e92efaf8fc 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,6 +7,7 @@ USING: kernel namespaces sequences assocs builder continuations tools.browser tools.test io.encodings.utf8 + combinators.cleave bootstrap.stage2 benchmark builder.util ; IN: builder.test @@ -14,8 +15,18 @@ IN: builder.test : do-load ( -- ) try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ; +! : do-tests ( -- ) +! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; + : do-tests ( -- ) - run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; + run-all-tests + "../test-all-vocabs" utf8 + [ + [ keys . ] + [ test-failures. ] + bi + ] + with-file-writer ; : do-benchmarks ( -- ) run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;