Merge branch 'master' of git://factorcode.org/git/wrunt

extra/gap-buffer/cursortree/cursortree-tests.factor

@@ -1,4 +1,6 @@
-USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ;
+USING: assocs kernel gap-buffer.cursortree tools.test sequences trees
+arrays strings ;
+IN: gap-buffer.cursortree.tests
 
 [ t ] [ "this is a test string" <cursortree> 0 <left-cursor> at-beginning? ] unit-test
 [ t ] [ "this is a test string" <cursortree> dup length  <left-cursor> at-end? ] unit-test
@@ -6,7 +8,8 @@ USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ;
 [ CHAR: i ] [ "this is a test string" <cursortree> 3 <left-cursor> element< ] unit-test
 [ CHAR: s ] [ "this is a test string" <cursortree> 3 <left-cursor> element> ] unit-test
 [ t ] [ "this is a test string" <cursortree> 3 <left-cursor> 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" <cursortree> 3 <left-cursor> 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test
+[ 0 ] [ "this is a test string" <cursortree> dup dup 3 <left-cursor> remove-cursor cursors length ] unit-test
+[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> 8 over set-cursor-pos dup 1array swap cursor-tree cursors sequence= ] unit-test
 [ "this is no longer a test string" ] [ "this is a test string" <cursortree> 8 <left-cursor> "no longer " over insert cursor-tree >string ] unit-test
 [ "refactor" ] [ "factor" <cursortree> 0 <left-cursor> CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test
 [ "refactor" ] [ "factor" <cursortree> 0 <right-cursor> CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test

extra/gap-buffer/cursortree/cursortree.factor

@@ -1,6 +1,7 @@
 ! 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 ;
+USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
+sequences quotations ;
 IN: gap-buffer.cursortree
 
 TUPLE: cursortree cursors ;
@@ -18,13 +19,12 @@ TUPLE: cursor i tree ;
 TUPLE: left-cursor ;
 TUPLE: right-cursor ;
 
-: cursor-index ( cursor -- i ) cursor-i ; inline
+: cursor-index ( cursor -- i ) cursor-i ;
 
-: add-cursor ( cursortree cursor -- ) dup cursor-index rot avl-insert ; 
+: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ; 
 
 : remove-cursor ( cursortree cursor -- )
-   cursor-index swap delete-at ; 
-   ! dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
+    tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
 
 : set-cursor-index ( index cursor -- )
     dup cursor-tree over remove-cursor tuck set-cursor-i
@@ -49,14 +49,17 @@ M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] ke
 : <right-cursor> ( cursortree pos -- right-cursor )
     right-cursor construct-empty make-cursor ;
 
+: cursors ( cursortree -- seq )
+    cursortree-cursors values concat ;
+
 : cursor-positions ( cursortree -- seq )
-    cursortree-cursors tree-values [ cursor-pos ] map ;
+    cursors [ 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 ;
+    cursors 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 ;
@@ -81,7 +84,7 @@ 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 ; 
+    tuck cursortree-cursors at [ fix-cursor ] with each ;
 
 M: cursortree delete* ( pos cursortree -- )
     tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;

extra/gap-buffer/gap-buffer.factor

@@ -44,15 +44,36 @@ M: gb like ( seq gb -- seq ) drop <gb> ;
 
 M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
 
+: valid-position? ( pos gb -- ? )
+    #! one element past the end of the buffer is a valid position when we're inserting
+    length -1 swap between? ;
+
+: valid-index? ( i gb -- ? )
+    buffer-length -1 swap between? ;
+
+TUPLE: position-out-of-bounds position gap-buffer ;
+C: <position-out-of-bounds> position-out-of-bounds
+
 : position>index ( pos gb -- i )
-    2dup gb-gap-start >= [
-        gap-length +
-    ] [ drop ] if ;
+    2dup valid-position? [
+        2dup gb-gap-start >= [
+            gap-length +
+        ] [ drop ] if
+    ] [
+        <position-out-of-bounds> throw
+    ] if ;
+
+TUPLE: index-out-of-bounds index gap-buffer ;
+C: <index-out-of-bounds> index-out-of-bounds
 
 : index>position ( i gb -- pos )
-    2dup gb-gap-end >= [
-        gap-length -
-    ] [ drop ] if ;
+    2dup valid-index? [
+        2dup gb-gap-end >= [
+            gap-length -
+        ] [ drop ] if
+    ] [
+        <index-out-of-bounds> throw
+    ] if ;
 
 M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
     
@@ -159,6 +180,7 @@ INSTANCE: gb virtual-sequence
 : fix-gap ( n gb -- )
     2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
 
+! moving the gap to position 5 means that the element in position 5 will be immediately after the gap
 GENERIC: move-gap ( n gb -- )
 
 M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;

extra/hooks/hooks-tests.factor

@@ -1,14 +0,0 @@
-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

extra/hooks/hooks.factor

@@ -1,28 +0,0 @@
-! 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 <digraph> ] cache ;
-
-: reset-hook ( hook -- )
-    <digraph> 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 ;
-

extra/semantic-db/hierarchy/hierarchy.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ;
+USING: accessors db.tuples kernel new-slots semantic-db
+semantic-db.relations sorting sequences sequences.deep ;
 IN: semantic-db.hierarchy
 
 TUPLE: tree id children ;
@@ -33,6 +34,9 @@ C: <tree> tree
 : get-node-hierarchy ( node-id -- tree )
     dup children [ get-node-hierarchy ] map <tree> ;
 
+: uniq ( sorted-seq -- seq )
+    f swap [ tuck = not ] subset nip ;
+
 : (get-root-nodes) ( node-id -- root-nodes/node-id )
     dup parents dup empty? [
         drop
@@ -41,4 +45,4 @@ C: <tree> tree
     ] if ;
 
 : get-root-nodes ( node-id -- root-nodes )
-    (get-root-nodes) flatten ;
+    (get-root-nodes) flatten natural-sort uniq ;

extra/semantic-db/semantic-db-tests.factor

@@ -1,18 +1,27 @@
-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 ;
+USING: accessors arrays continuations db db.sqlite db.tuples io.files
+kernel math namespaces semantic-db semantic-db.context
+semantic-db.hierarchy semantic-db.relations sequences tools.test
+tools.walker ;
 IN: semantic-db.tests
 
-[
+: db-path "semantic-db-test.db" temp-file ;
+: test-db db-path sqlite-db ;
+: delete-db [ db-path delete-file ] ignore-errors ;
+
+delete-db
+
+test-db [
     create-node-table create-arc-table
     [ 1 ] [ "first node" create-node* ] unit-test
     [ 2 ] [ "second node" create-node* ] unit-test
     [ 3 ] [ "third node" create-node* ] unit-test
     [ 4 ] [ f create-node* ] unit-test
     [ 5 ] [ 1 2 3 create-arc* ] unit-test
-] with-tmp-sqlite
+] with-db
 
-[
+delete-db
+
+test-db [
     init-semantic-db
     "test content" create-context* [
         [ 4 ] [ context ] unit-test
@@ -35,10 +44,12 @@ IN: semantic-db.tests
     ! [ 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
+] with-db
+
+delete-db
 
 ! test hierarchy
-[
+test-db [
     init-semantic-db
     "family tree" create-context* [
         "adam" create-node* "adam" set
@@ -52,7 +63,9 @@ IN: semantic-db.tests
         [ { "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 break get-root-nodes [ node-content ] map ] unit-test
+        [ { "adam" "eve" } ] [ "charlie" get 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
+] with-db
+
+delete-db

extra/semantic-db/semantic-db.factor

@@ -86,3 +86,4 @@ arc "arc"
     #! 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* ;
+

extra/triggers/authors.txt

@@ -0,0 +1 @@
+Alex Chapman

extra/triggers/summary.txt

@@ -0,0 +1 @@
+triggers allow you to register code to be 'triggered'

extra/triggers/triggers-tests.factor

@@ -0,0 +1,14 @@
+USING: triggers kernel tools.test ;
+IN: triggers.tests
+
+SYMBOL: test-trigger
+test-trigger reset-trigger
+: add-test-trigger test-trigger add-trigger ;
+[ ] [ test-trigger call-trigger ] unit-test
+[ "op called" ] [ "op" [ "op called" ] add-test-trigger test-trigger call-trigger ] unit-test
+[ "first called" "second called" ] [
+    test-trigger reset-trigger
+    "second op" [ "second called" ] add-test-trigger
+    "first op" [ "first called" ] add-test-trigger
+    test-trigger call-trigger
+] unit-test

extra/triggers/triggers.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: triggers
+
+: triggers ( -- triggers )
+    \ triggers global [ drop H{ } clone ] cache ;
+
+: trigger-graph ( trigger -- graph )
+    triggers [ drop <digraph> ] cache ;
+
+: reset-trigger ( trigger -- )
+    <digraph> swap triggers set-at ;
+
+: add-trigger ( key quot trigger -- )
+    #! trigger should be a symbol. Note that symbols with the same name but
+    #! different vocab are not equal
+    trigger-graph add-vertex ; 
+
+: before ( key1 key2 trigger -- )
+    trigger-graph add-edge ;
+
+: after ( key1 key2 trigger -- )
+    swapd before ;
+
+: call-trigger ( trigger -- )
+    trigger-graph topological-sorted-values [ call ] each ;
+