From e0d8a52a291091b3e5a9efa368bc2f700bc179e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:08:19 -0500 Subject: [PATCH 01/26] chmod the executable --- extra/tools/deploy/macosx/macosx.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 0b71ac5209..d59665488a 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -11,6 +11,9 @@ IN: tools.deploy.macosx : rm ( path -- ) "rm -rf \"" swap "\"" 3append run-process ; +: chmod ( path perms -- ) + [ "chmod " % % " \"" % % "\"" % ] "" make run-process ; + : bundle-dir ( -- dir ) vm parent-directory parent-directory ; @@ -19,7 +22,9 @@ IN: tools.deploy.macosx >r "Contents" path+ r> path+ copy-directory ; : copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" path+ swap path+ vm swap [ copy-file ] keep ; + "Contents/MacOS/" path+ swap path+ vm swap + [ copy-file ] keep + [ "755" chmod ] keep ; : copy-fonts ( name -- ) "fonts/" resource-path From 821cabeb4472b49ae50946b1aacc545d86dbbe98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:08:28 -0500 Subject: [PATCH 02/26] Fix hello-world deploy config --- extra/hello-world/deploy.factor | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 95d7d625c1..c8f69648a5 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,12 +1,13 @@ USING: tools.deploy.config ; -V{ - { deploy-ui? f } - { deploy-io 3 } +H{ { deploy-reflection 1 } - { deploy-compiler? t } - { deploy-math? f } - { deploy-word-props? f } - { deploy-c-types? f } - { "stop-after-last-window?" t } { deploy-name "Hello world (console)" } + { deploy-word-props? f } + { "stop-after-last-window?" t } + { deploy-c-types? f } + { deploy-compiler? f } + { deploy-word-defs? f } + { deploy-io 2 } + { deploy-ui? f } + { deploy-math? f } } From b4f6d7aa1c9c0e0bbee54cf7a5adbeb3b08d96ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:12:21 -0500 Subject: [PATCH 03/26] Fix accidental tools.deploy -> compiler dependency --- extra/cfdg/models/flower6/deploy.factor | 12 ++++++++++++ extra/hello-world/deploy.factor | 8 ++++---- extra/springies/models/belt-tire/deploy.factor | 13 +++++++++++++ extra/tools/deploy/shaker/shaker.factor | 8 ++++---- 4 files changed, 33 insertions(+), 8 deletions(-) create mode 100644 extra/cfdg/models/flower6/deploy.factor create mode 100644 extra/springies/models/belt-tire/deploy.factor diff --git a/extra/cfdg/models/flower6/deploy.factor b/extra/cfdg/models/flower6/deploy.factor new file mode 100644 index 0000000000..d6dadc035d --- /dev/null +++ b/extra/cfdg/models/flower6/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 2 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "cfdg.models.flower6.app" } +} diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index c8f69648a5..06bad872be 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,13 +1,13 @@ USING: tools.deploy.config ; H{ - { deploy-reflection 1 } - { deploy-name "Hello world (console)" } + { deploy-math? f } + { deploy-word-defs? f } { deploy-word-props? f } + { deploy-name "Hello world (console)" } { "stop-after-last-window?" t } { deploy-c-types? f } { deploy-compiler? f } - { deploy-word-defs? f } { deploy-io 2 } { deploy-ui? f } - { deploy-math? f } + { deploy-reflection 1 } } diff --git a/extra/springies/models/belt-tire/deploy.factor b/extra/springies/models/belt-tire/deploy.factor new file mode 100644 index 0000000000..ed522d5ee9 --- /dev/null +++ b/extra/springies/models/belt-tire/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 2 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "Belt Tire.app" } +} diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 52e1486199..0322ed372f 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -5,7 +5,7 @@ assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend -quotations words.private tools.deploy.config compiler ; +quotations words.private tools.deploy.config ; IN: tools.deploy.shaker : show ( msg -- ) @@ -24,7 +24,7 @@ IN: tools.deploy.shaker "Stripping debugger" show "resource:extra/tools/deploy/shaker/strip-debugger.factor" run-file - recompile + do-parse-hook ] when ; : strip-libc ( -- ) @@ -32,7 +32,7 @@ IN: tools.deploy.shaker "Stripping manual memory management debug code" show "resource:extra/tools/deploy/shaker/strip-libc.factor" run-file - recompile + do-parse-hook ] when ; : strip-cocoa ( -- ) @@ -40,7 +40,7 @@ IN: tools.deploy.shaker "Stripping unused Cocoa methods" show "resource:extra/tools/deploy/shaker/strip-cocoa.factor" run-file - recompile + do-parse-hook ] when ; : strip-assoc ( retained-keys assoc -- newassoc ) From b85af601c04b288189b4ccb46c4c9b4523cc7e84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:23:48 -0500 Subject: [PATCH 04/26] Document deployment --- extra/tools/deploy/deploy-docs.factor | 20 ++++++++++++-------- extra/ui/tools/deploy/deploy-docs.factor | 14 ++++++++++++++ extra/ui/tools/tools-docs.factor | 4 +++- 3 files changed, 29 insertions(+), 9 deletions(-) create mode 100644 extra/ui/tools/deploy/deploy-docs.factor diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor index 29e0da1f5c..f6e9cb2882 100644 --- a/extra/tools/deploy/deploy-docs.factor +++ b/extra/tools/deploy/deploy-docs.factor @@ -2,16 +2,20 @@ USING: help.markup help.syntax words alien.c-types assocs kernel ; IN: tools.deploy -ARTICLE: "tools.deploy" "Stand-alone image deployment" -"The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook." +ARTICLE: "tools.deploy" "Application deployment" +"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications." $nl "For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:" -{ $code "\"hello-world\" deploy" } -"This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):" -{ $code "./factor -i=hello-world.image" "Hello world" } - -"Once the necessary deployment flags have been set, a deployment image can be generated:" -{ $subsection deploy } ; +{ $code "\"hello-ui\" deploy" } +"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message." +$nl +"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size." +$nl +"You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment." +{ $subsection "prepare-deploy" } +"Once the necessary deployment flags have been set, the application can be deployed:" +{ $subsection deploy } +{ $see-also "ui.tools.deploy" } ; ABOUT: "tools.deploy" diff --git a/extra/ui/tools/deploy/deploy-docs.factor b/extra/ui/tools/deploy/deploy-docs.factor new file mode 100644 index 0000000000..4898b651a1 --- /dev/null +++ b/extra/ui/tools/deploy/deploy-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ui.tools.deploy ; + +HELP: deploy-tool +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "Opens the graphical deployment tool for the specified vocabulary." } +{ $examples { $code "\"tetris\" deploy-tool" } } ; + +ARTICLE: "ui.tools.deploy" "Application deployment UI tool" +"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically." +$nl +"To start the tool, pass a vocabulary name to a word:" +{ $subsection deploy-tool } +"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu." +{ $see-also "tools.deploy" } ; diff --git a/extra/ui/tools/tools-docs.factor b/extra/ui/tools/tools-docs.factor index e80dfe3c33..df795fa987 100644 --- a/extra/ui/tools/tools-docs.factor +++ b/extra/ui/tools/tools-docs.factor @@ -130,12 +130,14 @@ $nl { $subsection "ui-presentations" } { $subsection "ui-completion" } { $heading "Tools" } -"All development tools are integrated into a single-window " { $emphasis "workspace" } "." +"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:" { $subsection "ui-listener" } { $subsection "ui-browser" } { $subsection "ui-inspector" } { $subsection "ui-walker" } { $subsection "ui-profiler" } +"Additional tools:" +{ $subsection "ui.tools.deploy" } "Platform-specific features:" { $subsection "ui-cocoa" } ; From 86f98eac407a4339dd0f15c49a99db48e5857994 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:37:07 -0500 Subject: [PATCH 05/26] Deploy generates a stage1 image now if necessary --- core/bootstrap/image/image.factor | 5 ++++- extra/tools/deploy/deploy.factor | 21 +++++++++++++-------- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f6f3e5c0da..4204503372 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -442,7 +442,7 @@ M: curry ' PRIVATE> -: make-image ( architecture -- ) +: make-image ( arch -- ) [ parse-hook off prepare-image @@ -452,6 +452,9 @@ PRIVATE> image get image-name write-image ] with-scope ; +: my-arch ( -- arch ) + cpu dup "ppc" = [ os "-" rot 3append ] when ; + : make-images ( -- ) { "x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm" diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index adee30a8bc..7c0dabc458 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -5,25 +5,30 @@ assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend -quotations io.launcher words.private tools.deploy.config ; +quotations io.launcher words.private tools.deploy.config +bootstrap.image ; IN: tools.deploy @@ -57,7 +62,7 @@ IN: tools.deploy PRIVATE> : deploy* ( vm image vocab config -- ) - deploy-command-line stage2 ; + stage1 deploy-command-line stage2 ; SYMBOL: deploy-implementation From af83b87b7d8acd4467f59c231acc54d299e5ea58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:37:23 -0500 Subject: [PATCH 06/26] Minor improvement to fep's object dumpmer --- vm/debug.c | 1 + 1 file changed, 1 insertion(+) diff --git a/vm/debug.c b/vm/debug.c index 733f4eb49c..55ffcadca6 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -200,6 +200,7 @@ void dump_objects(F_FIXNUM type) { if(type == -1 || type_of(obj) == type) { + printf("%lx ",obj); print_nested_obj(obj,3); printf("\n"); } From 0051acbb2e47adefefca7e0f9b9a8fef9fb67737 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:40:48 -0500 Subject: [PATCH 07/26] Linux/ARM fixes with help from doublec --- Makefile | 2 ++ vm/Config.linux.arm | 1 + vm/Config.unix | 2 +- vm/os-linux-arm.c | 23 +++++++++++++++++++++++ vm/os-linux-arm.h | 8 ++++---- 5 files changed, 31 insertions(+), 5 deletions(-) create mode 100644 vm/os-linux-arm.c diff --git a/Makefile b/Makefile index a67f24f19d..77a6fb6409 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,6 @@ CC = gcc +AR = ar +LD = ld EXECUTABLE = factor VERSION = 0.91 diff --git a/vm/Config.linux.arm b/vm/Config.linux.arm index 4b8c8415db..26acde562d 100644 --- a/vm/Config.linux.arm +++ b/vm/Config.linux.arm @@ -1,2 +1,3 @@ include vm/Config.linux include vm/Config.arm +PLAF_DLL_OBJS += vm/os-linux-arm.o diff --git a/vm/Config.unix b/vm/Config.unix index 73934d7f41..390a719c77 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -21,5 +21,5 @@ endif # LINKER = gcc -shared -o # LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor -LINKER = ar rcs +LINKER = $(AR) rcs LINK_WITH_ENGINE = -Wl,--whole-archive -lfactor -Wl,-no-whole-archive diff --git a/vm/os-linux-arm.c b/vm/os-linux-arm.c new file mode 100644 index 0000000000..217fb58fa7 --- /dev/null +++ b/vm/os-linux-arm.c @@ -0,0 +1,23 @@ +#include "master.h" + +void flush_icache(CELL start, CELL len) +{ + int result; + + /* XXX: why doesn't this work on Nokia n800? It should behave + identically to the below assembly. */ + /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */ + + __asm__ __volatile__ ( + "mov r0, %1\n" + "sub r1, %2, #1\n" + "mov r2, #0\n" + "swi " __sys1(__ARM_NR_cacheflush) "\n" + "mov %0, r0\n" + : "=r" (result) + : "r" (start), "r" (start + len) + : "r0","r1","r2"); + + if(result < 0) + critical_error("flush_icache() failed",result); +} diff --git a/vm/os-linux-arm.h b/vm/os-linux-arm.h index 2e3d6062ed..6e078b014d 100644 --- a/vm/os-linux-arm.h +++ b/vm/os-linux-arm.h @@ -8,7 +8,7 @@ INLINE void *ucontext_stack_pointer(void *uap) return (void *)ucontext->uc_mcontext.arm_sp; } -INLINE void flush_icache(CELL start, CELL len) -{ - syscall(__ARM_NR_cacheflush,start,start + len,0); -} +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) + +void flush_icache(CELL start, CELL len); From f301d365350e508ad43a603e4df8d16cccc24e7f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:41:23 -0600 Subject: [PATCH 08/26] Move dlists to core/ Delete heaps --- {extra => core}/dlists/authors.txt | 1 + core/dlists/dlists-docs.factor | 74 ++++++++++++++++++ core/dlists/dlists-tests.factor | 61 +++++++++++++++ core/dlists/dlists.factor | 121 +++++++++++++++++++++++++++++ {extra => core}/dlists/summary.txt | 0 {extra => core}/dlists/tags.txt | 0 extra/dlists/dlists-tests.factor | 54 ------------- extra/dlists/dlists.factor | 100 ------------------------ extra/heaps/heaps-tests.factor | 32 -------- extra/heaps/heaps.factor | 112 -------------------------- 10 files changed, 257 insertions(+), 298 deletions(-) rename {extra => core}/dlists/authors.txt (59%) create mode 100644 core/dlists/dlists-docs.factor create mode 100644 core/dlists/dlists-tests.factor create mode 100644 core/dlists/dlists.factor rename {extra => core}/dlists/summary.txt (100%) rename {extra => core}/dlists/tags.txt (100%) delete mode 100644 extra/dlists/dlists-tests.factor delete mode 100644 extra/dlists/dlists.factor delete mode 100644 extra/heaps/heaps-tests.factor delete mode 100644 extra/heaps/heaps.factor diff --git a/extra/dlists/authors.txt b/core/dlists/authors.txt similarity index 59% rename from extra/dlists/authors.txt rename to core/dlists/authors.txt index 09839c9c91..ebeb56efd2 100644 --- a/extra/dlists/authors.txt +++ b/core/dlists/authors.txt @@ -1 +1,2 @@ Mackenzie Straight +Doug Coleman diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor new file mode 100644 index 0000000000..c5e41e9446 --- /dev/null +++ b/core/dlists/dlists-docs.factor @@ -0,0 +1,74 @@ +USING: help.markup help.syntax kernel ; +IN: dlists + +ARTICLE: "dlists" "Doubly-linked lists" +"A doubly-linked list is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object. Objects can be pushed and popped from the front and back of the list. The linked list keeps track of its length, so finding the length is O(1)." +; + +HELP: dlist-empty? +{ $values { "dlist" { $link dlist } } { "?" "a boolean" } } +{ $description "Returns true if a " { $link dlist } " is empty." } +{ $notes "This operation is O(1)." } ; + +HELP: push-front +{ $values { "obj" "an object" } { "dlist" dlist } } +{ $description "Push the object onto the front of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-back pop-front pop-front* pop-back pop-back* } ; + +HELP: push-back +{ $values { "obj" "an object" } { "dlist" dlist } } +{ $description "Push the object onto the back of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front pop-front pop-front* pop-back pop-back* } ; + +HELP: pop-front +{ $values { "dlist" dlist } { "obj" "an object" } } +{ $description "Pop the object off the front of the " { $link dlist } " and return the object." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front* pop-back pop-back* } ; + +HELP: pop-front* +{ $values { "dlist" dlist } } +{ $description "Pop the object off the front of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-back pop-back* } ; + +HELP: pop-back +{ $values { "dlist" dlist } { "obj" "an object" } } +{ $description "Pop the object off the back of the " { $link dlist } " and return the object." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-front* pop-back* } ; + +HELP: pop-back* +{ $values { "dlist" dlist } } +{ $description "Pop the object off the back of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-front* pop-back } ; + +HELP: dlist-find +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } +{ $notes "Returns a boolean to allow dlists to store " { $link f } "." + $nl + "This operation is O(n)." +} ; + +HELP: dlist-contains? +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } } +{ $description "Just like " { $link dlist-find } " except it doesn't return the object." } +{ $notes "This operation is O(n)." } ; + +HELP: delete-node* +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." } +{ $notes "This operation is O(n)." } ; + +HELP: delete-node +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } +{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." } +{ $notes "This operation is O(n)." } ; + +HELP: dlist-each +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } } +{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor new file mode 100644 index 0000000000..f4482d680d --- /dev/null +++ b/core/dlists/dlists-tests.factor @@ -0,0 +1,61 @@ +USING: dlists dlists.private kernel tools.test ; +IN: temporary + +[ t ] [ dlist-empty? ] unit-test + +[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ] +[ 1 over push-front ] unit-test + +! Make sure empty lists are empty +[ t ] [ dlist-empty? ] unit-test +[ f ] [ 1 over push-front dlist-empty? ] unit-test +[ f ] [ 1 over push-back dlist-empty? ] unit-test + +[ 1 ] [ 1 over push-front pop-front ] unit-test +[ 1 ] [ 1 over push-front pop-back ] unit-test +[ 1 ] [ 1 over push-back pop-front ] unit-test +[ 1 ] [ 1 over push-back pop-back ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-front* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-back* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-front* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-back* ] unit-test + +! Test the prev,next links for two nodes +[ f ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-prev +] unit-test + +[ 2 ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-next dlist-node-obj +] unit-test + +[ 1 ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-next dlist-node-prev dlist-node-obj +] unit-test + +[ f ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-next dlist-node-next +] unit-test + +[ f f ] [ [ 1 = ] swap dlist-find ] unit-test +[ 1 t ] [ 1 over push-back [ 1 = ] swap dlist-find ] unit-test +[ f f ] [ 1 over push-back [ 2 = ] swap dlist-find ] unit-test +[ f ] [ 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test + +[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test + +[ 0 ] [ dlist-length ] unit-test +[ 1 ] [ 1 over push-front dlist-length ] unit-test +[ 0 ] [ 1 over push-front dup pop-front* dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor new file mode 100644 index 0000000000..da05df9d80 --- /dev/null +++ b/core/dlists/dlists.factor @@ -0,0 +1,121 @@ +! Copyright (C) 2007 Mackenzie Straight, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel math ; +IN: dlists + +TUPLE: dlist front back length ; +: ( -- obj ) + dlist construct-empty + 0 over set-dlist-length ; + + dlist-node + +: dlist-empty? ( dlist -- ? ) dlist-front not ; + +: inc-length ( dlist -- ) + [ dlist-length 1+ ] keep set-dlist-length ; inline + +: dec-length ( dlist -- ) + [ dlist-length 1- ] keep set-dlist-length ; inline + +: set-prev-when ( dlist-node dlist-node/f -- ) + [ set-dlist-node-prev ] [ drop ] if* ; + +: set-next-when ( dlist-node dlist-node/f -- ) + [ set-dlist-node-next ] [ drop ] if* ; + +: set-next-prev ( dlist-node -- ) + dup dlist-node-next set-prev-when ; + +: normalize-front ( dlist -- ) + dup dlist-back [ drop ] [ f swap set-dlist-front ] if ; + +: normalize-back ( dlist -- ) + dup dlist-front [ drop ] [ f swap set-dlist-back ] if ; + +: set-back-to-front ( dlist -- ) + dup dlist-back + [ drop ] [ dup dlist-front swap set-dlist-back ] if ; + +: set-front-to-back ( dlist -- ) + dup dlist-front + [ drop ] [ dup dlist-back swap set-dlist-front ] if ; +PRIVATE> + +: push-front ( obj dlist -- ) + [ dlist-front f swap dup set-next-prev ] keep + [ set-dlist-front ] keep + [ set-back-to-front ] keep + inc-length ; + +: push-back ( obj dlist -- ) + [ dlist-back f ] keep + [ dlist-back set-next-when ] 2keep + [ set-dlist-back ] keep + [ set-front-to-back ] keep + inc-length ; + +: pop-front ( dlist -- obj ) + dup dlist-front [ + dlist-node-next + f over set-prev-when + swap set-dlist-front + ] 2keep dlist-node-obj + swap [ normalize-back ] keep dec-length ; + +: pop-front* ( dlist -- ) pop-front drop ; + +: pop-back ( dlist -- obj ) + [ + dlist-back dup dlist-node-prev f over set-next-when + ] keep + [ set-dlist-back ] keep + [ normalize-front ] keep + dec-length + dlist-node-obj ; + +: pop-back* ( dlist -- ) pop-back drop ; + +: (dlist-find-node) ( quot dlist-node -- node/f ? ) + dup dlist-node-obj pick dupd call [ + drop nip t + ] [ + drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* + ] if ; + +: dlist-find-node ( quot dlist -- node/f ? ) + dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; + +: dlist-find ( quot dlist -- obj/f ? ) + dlist-find-node dup [ >r dlist-node-obj r> ] when ; + +: dlist-contains? ( quot dlist -- ? ) + dlist-find nip ; + +: (delete-node) ( dlist dlist-node -- ) + { + { [ 2dup >r dlist-front r> = ] [ drop pop-front* ] } + { [ 2dup >r dlist-back r> = ] [ drop pop-back* ] } + { [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when + dec-length ] } + } cond ; + +: delete-node ( quot dlist -- obj/f ) + tuck dlist-find-node [ + [ (delete-node) ] keep [ dlist-node-obj ] [ f ] if* + ] [ + 2drop f + ] if ; + +: (dlist-each-node) ( quot dlist -- ) + over + [ 2dup call >r dlist-node-next r> (dlist-each-node) ] + [ 2drop ] if ; + +: dlist-each-node ( quot dlist -- ) + >r dlist-front r> (dlist-each-node) ; inline + +: dlist-each ( dlist quot -- ) + [ dlist-node-obj ] swap compose dlist-each-node ; inline diff --git a/extra/dlists/summary.txt b/core/dlists/summary.txt similarity index 100% rename from extra/dlists/summary.txt rename to core/dlists/summary.txt diff --git a/extra/dlists/tags.txt b/core/dlists/tags.txt similarity index 100% rename from extra/dlists/tags.txt rename to core/dlists/tags.txt diff --git a/extra/dlists/dlists-tests.factor b/extra/dlists/dlists-tests.factor deleted file mode 100644 index cdcee84dc0..0000000000 --- a/extra/dlists/dlists-tests.factor +++ /dev/null @@ -1,54 +0,0 @@ -IN: temporary -USING: dlists kernel strings tools.test math ; - -[ "junk" ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] swap dlist-remove -] unit-test - -[ 5 20 ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] over dlist-remove drop - [ ] dlist-each -] unit-test - -[ "junk" ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ integer? ] over dlist-remove drop - [ integer? ] over dlist-remove drop - [ ] dlist-each -] unit-test - -[ t ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] swap dlist-contains? -] unit-test - -[ t ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ integer? ] swap dlist-contains? -] unit-test - -[ f ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] over dlist-remove drop - [ string? ] swap dlist-contains? -] unit-test diff --git a/extra/dlists/dlists.factor b/extra/dlists/dlists.factor deleted file mode 100644 index 9ff7ce5f6f..0000000000 --- a/extra/dlists/dlists.factor +++ /dev/null @@ -1,100 +0,0 @@ -! Copyright (C) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -IN: dlists -USING: kernel math ; - -! Double-linked lists. - -TUPLE: dlist first last ; - -: dlist construct-empty ; - -TUPLE: dlist-node data prev next ; - -C: dlist-node - -: dlist-push-end ( data dlist -- ) - [ dlist-last f ] keep - [ dlist-last [ dupd set-dlist-node-next ] when* ] keep - 2dup set-dlist-last - dup dlist-first [ 2drop ] [ set-dlist-first ] if ; - -: dlist-empty? ( dlist -- ? ) - dlist-first f = ; - -: (unlink-prev) ( dlist dnode -- ) - dup dlist-node-prev [ - dupd swap dlist-node-next swap set-dlist-node-next - ] when* - 2dup swap dlist-first eq? [ - dlist-node-next swap set-dlist-first - ] [ 2drop ] if ; - -: (unlink-next) ( dlist dnode -- ) - dup dlist-node-next [ - dupd swap dlist-node-prev swap set-dlist-node-prev - ] when* - 2dup swap dlist-last eq? [ - dlist-node-prev swap set-dlist-last - ] [ 2drop ] if ; - -: (dlist-unlink) ( dlist dnode -- ) - [ (unlink-prev) ] 2keep (unlink-next) ; - -: (dlist-pop-front) ( dlist -- data ) - [ dlist-first dlist-node-data ] keep dup dlist-first (dlist-unlink) ; - -: dlist-pop-front ( dlist -- data ) - dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] if ; - -: (dlist-remove) ( dlist quot dnode -- obj/f ) - [ - [ dlist-node-data swap call ] 2keep rot [ - swapd [ (dlist-unlink) ] keep dlist-node-data nip - ] [ - dlist-node-next (dlist-remove) - ] if - ] [ - 2drop f - ] if* ; inline - -: dlist-remove ( quot dlist -- obj/f ) - #! Return first item in the dlist that when passed to the - #! predicate quotation, true is left on the stack. The - #! item is removed from the dlist. The quotation - #! must have stack effect ( obj -- bool ). - #! TODO: needs a better name. - dup dlist-first swapd (dlist-remove) ; inline - -: (dlist-contains?) ( pred dnode -- bool ) - [ - [ dlist-node-data swap call ] 2keep rot [ - 2drop t - ] [ - dlist-node-next (dlist-contains?) - ] if - ] [ - drop f - ] if* ; inline - -: dlist-contains? ( quot dlist -- obj/f ) - #! Return true if any item in the dlist that when passed to the - #! predicate quotation, true is left on the stack. - #! The 'pred' quotation must have stack effect ( obj -- bool ). - #! TODO: needs a better name. - dlist-first (dlist-contains?) ; inline - -: (dlist-each) ( quot dnode -- ) - [ - [ dlist-node-data swap call ] 2keep - dlist-node-next (dlist-each) - ] [ - drop - ] if* ; inline - -: dlist-each ( dlist quot -- ) - swap dlist-first (dlist-each) ; inline - -: dlist-length ( dlist -- length ) - 0 swap [ drop 1+ ] dlist-each ; - diff --git a/extra/heaps/heaps-tests.factor b/extra/heaps/heaps-tests.factor deleted file mode 100644 index a8087916e7..0000000000 --- a/extra/heaps/heaps-tests.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright 2007 Ryan Murphy -! See http://factorcode.org/license.txt for BSD license. - -USING: kernel math tools.test heaps heaps.private ; -IN: temporary - -[ pop-heap ] unit-test-fails -[ pop-heap ] unit-test-fails - -[ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test -[ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test - -! Binary Min Heap -{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test -{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test - -[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test - -[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ - { 3 5 4 6 5 7 6 8 } over push-heap* - 3 [ dup pop-heap* ] times -] unit-test - -[ 2 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test - -[ 1 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test - -[ 400 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test diff --git a/extra/heaps/heaps.factor b/extra/heaps/heaps.factor deleted file mode 100644 index 2ff9096483..0000000000 --- a/extra/heaps/heaps.factor +++ /dev/null @@ -1,112 +0,0 @@ -! Copyright (C) 2007 Ryan Murphy, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; -IN: heaps - - ( -- obj ) - V{ } clone heap construct-boa ; -PRIVATE> - -TUPLE: min-heap ; - -: ( -- obj ) - min-heap construct-delegate ; - -TUPLE: max-heap ; - -: ( -- obj ) - max-heap construct-delegate ; - -r left r> nth ; -: right-value ( n heap -- obj ) >r right r> nth ; -: up-value ( n vec -- obj ) >r up r> nth ; -: swap-up ( n vec -- ) >r dup up r> exchange ; -: last-index ( vec -- n ) length 1- ; - -GENERIC: heap-compare ( obj1 obj2 heap -- ? ) - -M: min-heap heap-compare drop <=> 0 > ; -M: max-heap heap-compare drop <=> 0 < ; - -: left-bounds-check? ( m heap -- ? ) - >r left r> heap-data length >= ; - -: right-bounds-check? ( m heap -- ? ) - >r right r> heap-data length >= ; - -: (up-heap) ( vec heap -- ) - [ - >r [ last-index ] keep [ up-value ] keep peek r> heap-compare - ] 2keep rot [ - >r dup last-index - [ over swap-up ] keep - up 1+ head-slice - r> (up-heap) - ] [ - 2drop - ] if ; - -: up-heap ( heap -- ) - [ heap-data ] keep (up-heap) ; - -: child ( m heap -- n ) - 2dup right-bounds-check? [ - drop left - ] [ - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare [ - right - ] [ - left - ] if - ] if ; - -: swap-down ( m heap -- ) - [ child ] 2keep heap-data exchange ; - -DEFER: down-heap - -: (down-heap) ( m heap -- ) - 2dup [ heap-data nth ] 2keep child pick - dupd [ heap-data nth swapd ] keep - heap-compare [ - -rot [ swap-down ] keep down-heap - ] [ - 3drop - ] if ; - -: down-heap ( m heap -- ) - 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; - -PRIVATE> - -: push-heap ( obj heap -- ) - tuck heap-data push up-heap ; - -: push-heap* ( seq heap -- ) - swap [ swap push-heap ] curry* each ; - -: peek-heap ( heap -- obj ) - heap-data first ; - -: pop-heap* ( heap -- ) - dup heap-data length 1 > [ - [ heap-data pop 0 ] keep - [ heap-data set-nth ] keep - >r 0 r> down-heap - ] [ - heap-data pop* - ] if ; - -: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ; - -: heap-empty? ( heap -- ? ) - heap-data empty? ; From 1a86c5fd8585e451aa18c84469621cc506af286f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:42:37 -0600 Subject: [PATCH 09/26] Move heaps to core/ Document heaps Renamed a lot of heaps words -- pop-heap -> heap-pop --- core/heaps/heaps-docs.factor | 41 ++++++++++++++ core/heaps/heaps-tests.factor | 20 +++---- core/heaps/heaps.factor | 102 ++++++++++++++++------------------ 3 files changed, 98 insertions(+), 65 deletions(-) create mode 100644 core/heaps/heaps-docs.factor diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor new file mode 100644 index 0000000000..a8f3d64b1e --- /dev/null +++ b/core/heaps/heaps-docs.factor @@ -0,0 +1,41 @@ +USING: heaps.private help.markup help.syntax kernel ; +IN: heaps + +ARTICLE: "heaps" "Heaps" +"A heap is a data structure that obeys the heap property. A min-heap will always have its smallest member available, as a max-heap will its largest. Objects stored on the heap must be comparable using the " { $link <=> } " operator, which may mean defining a new method on an object by using " { $link POSTPONE: M: } "." +; + + +HELP: +{ $values { "min-heap" min-heap } } +{ $description "Create a new " { $link min-heap } "." } +; + +HELP: +{ $values { "max-heap" max-heap } } +{ $description "Create a new " { $link max-heap } "." } +; + +HELP: heap-push +{ $values { "obj" "an object" } { "heap" "a heap" } } +{ $description "Push an object onto a heap." } ; + +HELP: heap-push-all +{ $values { "seq" "a sequence" } { "heap" "a heap" } } +{ $description "Push a sequence onto a heap." } ; + +HELP: heap-peek +{ $values { "heap" "a heap" } { "obj" "an object" } } +{ $description "Returns the first element in the heap and leaves it in the heap." } ; + +HELP: heap-pop* +{ $values { "heap" "a heap" } } +{ $description "Removes the first element from the heap." } ; + +HELP: heap-pop +{ $values { "heap" "a heap" } { "obj" "an object" } } +{ $description "Returns the first element in the heap and removes it from the heap." } ; + +HELP: heap-empty? +{ $values { "heap" "a heap" } { "?" "a boolean" } } +{ $description "Tests if a " { $link heap } " has no nodes." } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index a8087916e7..befbbc90fc 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -4,13 +4,13 @@ USING: kernel math tools.test heaps heaps.private ; IN: temporary -[ pop-heap ] unit-test-fails -[ pop-heap ] unit-test-fails +[ heap-pop ] unit-test-fails +[ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ f ] [ 1 over heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ f ] [ 1 over heap-push heap-empty? ] unit-test ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test @@ -18,15 +18,15 @@ IN: temporary { f } [ 5 3 T{ max-heap } heap-compare ] unit-test [ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test +[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over heap-push-all ] unit-test [ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ - { 3 5 4 6 5 7 6 8 } over push-heap* - 3 [ dup pop-heap* ] times + { 3 5 4 6 5 7 6 8 } over heap-push-all + 3 [ dup heap-pop* ] times ] unit-test -[ 2 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test +[ 2 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push heap-pop ] unit-test -[ 1 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test +[ 1 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test -[ 400 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test +[ 400 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 2ff9096483..74ca9e4b34 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -6,78 +6,74 @@ IN: heaps ( -- obj ) - V{ } clone heap construct-boa ; +: ( class -- obj ) + >r V{ } clone heap construct-boa r> + construct-delegate ; inline PRIVATE> TUPLE: min-heap ; -: ( -- obj ) - min-heap construct-delegate ; +: ( -- min-heap ) min-heap ; TUPLE: max-heap ; -: ( -- obj ) - max-heap construct-delegate ; +: ( -- max-heap ) max-heap ; r left r> nth ; -: right-value ( n heap -- obj ) >r right r> nth ; -: up-value ( n vec -- obj ) >r up r> nth ; -: swap-up ( n vec -- ) >r dup up r> exchange ; -: last-index ( vec -- n ) length 1- ; +: left ( n -- m ) 2 * 1+ ; inline +: right ( n -- m ) 2 * 2 + ; inline +: up ( n -- m ) 1- 2 /i ; inline +: left-value ( n heap -- obj ) >r left r> nth ; inline +: right-value ( n heap -- obj ) >r right r> nth ; inline +: up-value ( n vec -- obj ) >r up r> nth ; inline +: swap-up ( n vec -- ) >r dup up r> exchange ; inline +: last-index ( vec -- n ) length 1- ; inline GENERIC: heap-compare ( obj1 obj2 heap -- ? ) - M: min-heap heap-compare drop <=> 0 > ; M: max-heap heap-compare drop <=> 0 < ; +: heap-bounds-check? ( m heap -- ? ) + heap-data length >= ; inline + : left-bounds-check? ( m heap -- ? ) - >r left r> heap-data length >= ; + >r left r> heap-bounds-check? ; inline : right-bounds-check? ( m heap -- ? ) - >r right r> heap-data length >= ; + >r right r> heap-bounds-check? ; inline -: (up-heap) ( vec heap -- ) - [ - >r [ last-index ] keep [ up-value ] keep peek r> heap-compare - ] 2keep rot [ - >r dup last-index - [ over swap-up ] keep - up 1+ head-slice - r> (up-heap) +: up-heap-continue? ( vec heap -- ? ) + >r [ last-index ] keep [ up-value ] keep peek r> + heap-compare ; inline + +: up-heap ( vec heap -- ) + 2dup up-heap-continue? [ + >r dup last-index [ over swap-up ] keep + up 1+ head-slice r> up-heap ] [ 2drop ] if ; -: up-heap ( heap -- ) - [ heap-data ] keep (up-heap) ; +: (child) ( m heap -- n ) + dupd + [ heap-data left-value ] 2keep + [ heap-data right-value ] keep heap-compare + [ right ] [ left ] if ; : child ( m heap -- n ) - 2dup right-bounds-check? [ - drop left - ] [ - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare [ - right - ] [ - left - ] if - ] if ; + 2dup right-bounds-check? [ drop left ] [ (child) ] if ; : swap-down ( m heap -- ) [ child ] 2keep heap-data exchange ; DEFER: down-heap +: down-heap-continue? ( heap m heap -- m heap ? ) + [ heap-data nth ] 2keep child pick + dupd [ heap-data nth swapd ] keep heap-compare ; + : (down-heap) ( m heap -- ) - 2dup [ heap-data nth ] 2keep child pick - dupd [ heap-data nth swapd ] keep - heap-compare [ + 2dup down-heap-continue? [ -rot [ swap-down ] keep down-heap ] [ 3drop @@ -88,25 +84,21 @@ DEFER: down-heap PRIVATE> -: push-heap ( obj heap -- ) - tuck heap-data push up-heap ; +: heap-push ( obj heap -- ) + tuck heap-data push [ heap-data ] keep up-heap ; -: push-heap* ( seq heap -- ) - swap [ swap push-heap ] curry* each ; +: heap-push-all ( seq heap -- ) [ heap-push ] curry each ; -: peek-heap ( heap -- obj ) - heap-data first ; +: heap-peek ( heap -- obj ) heap-data first ; -: pop-heap* ( heap -- ) +: heap-pop* ( heap -- ) dup heap-data length 1 > [ - [ heap-data pop 0 ] keep - [ heap-data set-nth ] keep - >r 0 r> down-heap + [ heap-data pop ] keep + [ heap-data set-first ] keep + 0 swap down-heap ] [ heap-data pop* ] if ; -: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ; - -: heap-empty? ( heap -- ? ) - heap-data empty? ; +: heap-pop ( heap -- obj ) [ heap-data first ] keep heap-pop* ; +: heap-empty? ( heap -- ? ) heap-data empty? ; From b8561fdc1d8325fcb5a7f86945af1a73a50c71e8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:43:04 -0600 Subject: [PATCH 10/26] Change heap words in core/threads --- core/threads/threads.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 2cb7a3c3d0..074259dce6 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -17,15 +17,15 @@ M: sleeping <=> ( obj1 obj2 -- n ) : sleep-time ( -- ms ) sleep-queue get-global - dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ; + dup heap-empty? [ drop 1000 ] [ heap-peek sleeping-ms millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; : schedule-sleep ( ms continuation -- ) - sleeping construct-boa sleep-queue get-global push-heap ; + sleeping construct-boa sleep-queue get-global heap-push ; : wake-up ( -- continuation ) - sleep-queue get-global pop-heap sleeping-continuation ; + sleep-queue get-global heap-pop sleeping-continuation ; PRIVATE> From 6c8808dd8ddc789ebf0105c33129475072db44e3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:43:29 -0600 Subject: [PATCH 11/26] Check in core/dlists --- core/dlists/dlists.factor | 47 +++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 22 deletions(-) diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index da05df9d80..ac19e0cec1 100644 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -8,12 +8,12 @@ TUPLE: dlist front back length ; dlist construct-empty 0 over set-dlist-length ; +: dlist-empty? ( dlist -- ? ) dlist-front not ; + dlist-node -: dlist-empty? ( dlist -- ? ) dlist-front not ; - : inc-length ( dlist -- ) [ dlist-length 1+ ] keep set-dlist-length ; inline @@ -42,6 +42,24 @@ C: dlist-node : set-front-to-back ( dlist -- ) dup dlist-front [ drop ] [ dup dlist-back swap set-dlist-front ] if ; + +: (dlist-find-node) ( quot dlist-node -- node/f ? ) + dup dlist-node-obj pick dupd call [ + drop nip t + ] [ + drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* + ] if ; + +: dlist-find-node ( quot dlist -- node/f ? ) + dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; + +: (dlist-each-node) ( quot dlist -- ) + over + [ 2dup call >r dlist-node-next r> (dlist-each-node) ] + [ 2drop ] if ; + +: dlist-each-node ( quot dlist -- ) + >r dlist-front r> (dlist-each-node) ; inline PRIVATE> : push-front ( obj dlist -- ) @@ -78,16 +96,6 @@ PRIVATE> : pop-back* ( dlist -- ) pop-back drop ; -: (dlist-find-node) ( quot dlist-node -- node/f ? ) - dup dlist-node-obj pick dupd call [ - drop nip t - ] [ - drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* - ] if ; - -: dlist-find-node ( quot dlist -- node/f ? ) - dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; - : dlist-find ( quot dlist -- obj/f ? ) dlist-find-node dup [ >r dlist-node-obj r> ] when ; @@ -102,20 +110,15 @@ PRIVATE> dec-length ] } } cond ; -: delete-node ( quot dlist -- obj/f ) +: delete-node* ( quot dlist -- obj/f ? ) tuck dlist-find-node [ - [ (delete-node) ] keep [ dlist-node-obj ] [ f ] if* + [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if* ] [ - 2drop f + 2drop f f ] if ; -: (dlist-each-node) ( quot dlist -- ) - over - [ 2dup call >r dlist-node-next r> (dlist-each-node) ] - [ 2drop ] if ; - -: dlist-each-node ( quot dlist -- ) - >r dlist-front r> (dlist-each-node) ; inline +: delete-node ( quot dlist -- obj/f ) + delete-node* drop ; : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline From 3e40ab714e5ff552284f421d87984ebdde4b43d4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:50:19 -0600 Subject: [PATCH 12/26] Move delete-random to sequences.lib Add some unit tests --- extra/sequences/lib/lib-tests.factor | 6 ++++++ extra/sequences/lib/lib.factor | 4 +++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 470cd096e1..c170a0d20a 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -33,3 +33,9 @@ math.functions tools.test ; [ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ] [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test +[ f ] [ { } singleton? ] unit-test +[ t ] [ { "asdf" } singleton? ] unit-test +[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test + +[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test +[ V{ } [ delete-random drop ] keep length ] unit-test-fails diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index d6cf1fe1dc..74d59101ca 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel sequences math namespaces -sequences.private shuffle ; +random sequences.private shuffle ; IN: sequences.lib @@ -61,3 +61,5 @@ IN: sequences.lib : singleton? ( seq -- ? ) length 1 = ; +: delete-random ( seq -- value ) + [ length random ] keep [ nth ] 2keep delete-nth ; From 6de2fc53998790a28d34cf439768a39aa168e30d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:51:38 -0600 Subject: [PATCH 13/26] Moved delete-random to sequences.lib Add a space to a lot of lines =-O --- extra/channels/channels-tests.factor | 52 ++++++++++++++-------------- extra/channels/channels.factor | 5 +-- 2 files changed, 27 insertions(+), 30 deletions(-) diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index 5c339d3406..1a08fd3971 100644 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -10,39 +10,39 @@ IN: temporary ] unit-test { V{ 10 } } [ - V{ } clone - [ from swap push ] in-thread - 10 swap to + V{ } clone + [ from swap push ] in-thread + 10 swap to ] unit-test { 20 } [ - - [ 20 swap to ] in-thread - from + + [ 20 swap to ] in-thread + from ] unit-test { V{ 1 2 3 4 } } [ - V{ } clone - [ from swap push ] in-thread - [ from swap push ] in-thread - [ from swap push ] in-thread - [ from swap push ] in-thread - 4 over to - 2 over to - 1 over to - 3 swap to - [ <=> ] sort + V{ } clone + [ from swap push ] in-thread + [ from swap push ] in-thread + [ from swap push ] in-thread + [ from swap push ] in-thread + 4 over to + 2 over to + 1 over to + 3 swap to + natural-sort ] unit-test { V{ 1 2 4 9 } } [ - V{ } clone - [ 4 swap to ] in-thread - [ 2 swap to ] in-thread - [ 1 swap to ] in-thread - [ 9 swap to ] in-thread - 2dup from swap push - 2dup from swap push - 2dup from swap push - dupd from swap push - [ <=> ] sort + V{ } clone + [ 4 swap to ] in-thread + [ 2 swap to ] in-thread + [ 1 swap to ] in-thread + [ 9 swap to ] in-thread + 2dup from swap push + 2dup from swap push + 2dup from swap push + dupd from swap push + natural-sort ] unit-test diff --git a/extra/channels/channels.factor b/extra/channels/channels.factor index 54f0d7dd4e..07b5d2f5d5 100644 --- a/extra/channels/channels.factor +++ b/extra/channels/channels.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences threads continuations random math ; +USING: kernel sequences sequences.lib threads continuations random math ; IN: channels TUPLE: channel receivers senders ; @@ -15,9 +15,6 @@ GENERIC: from ( channel -- value ) Date: Mon, 5 Nov 2007 02:03:59 -0600 Subject: [PATCH 14/26] Remove a unit test --- extra/channels/channels-tests.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index 1a08fd3971..1f2436cf5d 100644 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -5,10 +5,6 @@ USING: kernel tools.test math channels channels.private sequences threads sorting ; IN: temporary -{ 3 t } [ - V{ 1 2 3 4 } clone [ delete-random ] keep length swap integer? -] unit-test - { V{ 10 } } [ V{ } clone [ from swap push ] in-thread From 40752e447df274581dbcd547a3466826b95730f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:04:33 -0600 Subject: [PATCH 15/26] Fix random number mechanism in remote channels --- extra/channels/remote/remote.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor index 5d62d17308..4f483b8775 100644 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Remote Channels -USING: kernel init namespaces assocs arrays +USING: kernel init namespaces assocs arrays random sequences channels match concurrency concurrency.distributed ; IN: channels.remote @@ -13,7 +13,7 @@ IN: channels.remote PRIVATE> : publish ( channel -- id ) - random-64 dup >r remote-channels set-at r> ; + random-256 dup >r remote-channels set-at r> ; : get-channel ( id -- channel ) remote-channels at ; From 1e60000395092bf2e72bac769ed2da64cdae5dd3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:05:01 -0600 Subject: [PATCH 16/26] Fix concurrency --- extra/concurrency/concurrency.factor | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index b59f758ad8..bbb7a7045a 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -26,7 +26,7 @@ TUPLE: thread timeout continuation continued? ; mailbox-data dlist-empty? ; : mailbox-put ( obj mailbox -- ) - [ mailbox-data dlist-push-end ] keep + [ mailbox-data push-back ] keep [ mailbox-threads ] keep V{ } clone swap set-mailbox-threads [ thread-continuation schedule-thread ] each yield ; @@ -51,7 +51,7 @@ TUPLE: thread timeout continuation continued? ; PRIVATE> : mailbox-get* ( mailbox timeout -- obj ) (mailbox-block-if-empty) - mailbox-data dlist-pop-front ; + mailbox-data pop-front ; : mailbox-get ( mailbox -- obj ) f mailbox-get* ; @@ -59,7 +59,7 @@ PRIVATE> : mailbox-get-all* ( mailbox timeout -- array ) (mailbox-block-if-empty) [ dup mailbox-empty? ] - [ dup mailbox-data dlist-pop-front ] + [ dup mailbox-data pop-front ] { } unfold ; : mailbox-get-all ( mailbox -- array ) @@ -74,7 +74,7 @@ PRIVATE> : mailbox-get?* ( pred mailbox timeout -- obj ) 2over >r >r (mailbox-block-unless-pred) r> r> - mailbox-data dlist-remove ; inline + mailbox-data delete-node ; inline : mailbox-get? ( pred mailbox -- obj ) f mailbox-get?* ; @@ -85,21 +85,19 @@ C: process GENERIC: send ( message process -- ) -: random-pid ( -- id ) 8 big-random ; - ; + [ ] random-256 make-mailbox ; : make-linked-process ( process -- process ) #! Return a process set to run on the local node. That process is #! linked to the process on the stack. It will receive a message if #! that process terminates. - 1quotation random-pid make-mailbox ; + 1quotation random-256 make-mailbox ; PRIVATE> : self ( -- process ) @@ -206,7 +204,7 @@ MATCH-VARS: ?from ?tag ; r self random-pid r> 3array ; + >r self random-256 r> 3array ; PRIVATE> : send-synchronous ( message process -- reply ) From 5719eeda88f875e3c01b4d214908fc755a68edaa Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:25:16 -0600 Subject: [PATCH 17/26] Document a couple of words in random Add a word to get a random 256-bit integer --- extra/random/random-docs.factor | 8 ++++++++ extra/random/random.factor | 2 ++ 2 files changed, 10 insertions(+) diff --git a/extra/random/random-docs.factor b/extra/random/random-docs.factor index 811b86496c..1d8334ab31 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/random-docs.factor @@ -21,3 +21,11 @@ HELP: random { $values { "seq" "a sequence" } { "elt" "a random element" } } { $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." } { $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ; + +HELP: big-random +{ $values { "n" "an integer" } { "r" "a random integer" } } +{ $description "Outputs an integer with n bytes worth of bits." } ; + +HELP: random-256 +{ $values { "r" "a random integer" } } +{ $description "Outputs an random integer 256 bits in length." } ; diff --git a/extra/random/random.factor b/extra/random/random.factor index 45ce99bcea..ff4487dd27 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -93,6 +93,8 @@ PRIVATE> : big-random ( n -- r ) [ drop (random) ] map >c-uint-array byte-array>bignum ; +: random-256 ( -- r ) 8 big-random ; inline + : random ( seq -- elt ) dup empty? [ drop f From 1df90f392d5601b3deb6ed72c8aa57665a97ae76 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:25:53 -0600 Subject: [PATCH 18/26] Move delete-random to sequences.lib --- extra/sequences/lib/lib.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 74d59101ca..33cfe80fcc 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,6 +1,5 @@ USING: combinators.lib kernel sequences math namespaces random sequences.private shuffle ; - IN: sequences.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From f26d8efa06cc5fd2702177f7da51797e96b57599 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:26:16 -0600 Subject: [PATCH 19/26] Add dlists and heaps to the handbook --- extra/help/handbook/handbook.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 9460903ffc..8f20b68cc1 100644 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -127,8 +127,9 @@ ARTICLE: "collections" "Collections" { $subsection "hashtables" } { $subsection "alists" } { $heading "Other collections" } -{ $subsection "queues" } -{ $subsection "buffers" } ; +{ $subsection "buffers" } +{ $subsection "dlists" } +{ $subsection "heaps" } ; USE: io.sockets From 599f1c60873a78244173048a8ac406eaa634e2e9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 11:01:11 -0500 Subject: [PATCH 20/26] Finish cleaning up erg's changes, remove queues --- core/dlists/dlists-docs.factor | 32 +++++++++++- core/dlists/dlists.factor | 6 +++ core/heaps/heaps-docs.factor | 26 +++++++++- core/queues/authors.txt | 1 - core/queues/queues-docs.factor | 77 ---------------------------- core/queues/queues-tests.factor | 12 ----- core/queues/queues.factor | 57 -------------------- core/queues/summary.txt | 1 - core/queues/tags.txt | 1 - core/threads/threads-docs.factor | 2 +- core/threads/threads.factor | 18 +++---- extra/help/handbook/handbook.factor | 6 +-- extra/help/markup/markup-docs.factor | 4 +- extra/ui/gadgets/gadgets.factor | 6 +-- extra/ui/gestures/gestures.factor | 2 +- extra/ui/ui.factor | 4 +- 16 files changed, 81 insertions(+), 174 deletions(-) delete mode 100644 core/queues/authors.txt delete mode 100644 core/queues/queues-docs.factor delete mode 100644 core/queues/queues-tests.factor delete mode 100644 core/queues/queues.factor delete mode 100644 core/queues/summary.txt delete mode 100644 core/queues/tags.txt diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor index c5e41e9446..a20d038621 100644 --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -2,8 +2,36 @@ USING: help.markup help.syntax kernel ; IN: dlists ARTICLE: "dlists" "Doubly-linked lists" -"A doubly-linked list is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object. Objects can be pushed and popped from the front and back of the list. The linked list keeps track of its length, so finding the length is O(1)." -; +"A doubly-linked list, or dlist, is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object." +$nl +"While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time." +$nl +"Dlists form a class:" +{ $subsection dlist } +{ $subsection dlist? } +"Constructing a dlist:" +{ $subsection } +"Double-ended queue protocol:" +{ $subsection dlist-empty? } +{ $subsection push-front } +{ $subsection pop-front } +{ $subsection pop-front* } +{ $subsection push-back } +{ $subsection pop-back } +{ $subsection pop-back* } +"Finding out the length:" +{ $subsection dlist-length } +"Iterating over elements:" +{ $subsection dlist-each } +{ $subsection dlist-find } +{ $subsection dlist-contains? } +"Deleting a node matching a predicate:" +{ $subsection delete-node* } +{ $subsection delete-node } +"Consuming all nodes:" +{ $subsection dlist-slurp } ; + +ABOUT: "dlists" HELP: dlist-empty? { $values { "dlist" { $link dlist } } { "?" "a boolean" } } diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index ac19e0cec1..890185d4c4 100644 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -4,6 +4,7 @@ USING: combinators kernel math ; IN: dlists TUPLE: dlist front back length ; + : ( -- obj ) dlist construct-empty 0 over set-dlist-length ; @@ -122,3 +123,8 @@ PRIVATE> : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline + +: dlist-slurp ( dlist quot -- ) + over dlist-empty? + [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ; + inline diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index a8f3d64b1e..3ed2813123 100644 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -2,9 +2,31 @@ USING: heaps.private help.markup help.syntax kernel ; IN: heaps ARTICLE: "heaps" "Heaps" -"A heap is a data structure that obeys the heap property. A min-heap will always have its smallest member available, as a max-heap will its largest. Objects stored on the heap must be comparable using the " { $link <=> } " operator, which may mean defining a new method on an object by using " { $link POSTPONE: M: } "." -; +"A heap is an implementation of a " { $emphasis "priority queue" } ", which is a structure that maintains a sorted set of elements. The key property is that insertion of an arbitrary element and removal of the first element (determined by order) is performed in O(log n) time." +$nl +"Heap elements are compared using the " { $link <=> } " generic word." +$nl +"There are two classes of heaps. Min-heaps sort their elements so that the minimum element is first:" +{ $subsection min-heap } +{ $subsection min-heap? } +{ $subsection } +"Max-heaps sort their elements so that the maximum element is first:" +{ $subsection min-heap } +{ $subsection min-heap? } +{ $subsection } +"Both obey a protocol." +$nl +"Queries:" +{ $subsection heap-empty? } +{ $subsection heap-peek } +"Insertion:" +{ $subsection heap-push } +{ $subsection heap-push-all } +"Removal:" +{ $subsection heap-pop* } +{ $subsection heap-pop } ; +ABOUT: "heaps" HELP: { $values { "min-heap" min-heap } } diff --git a/core/queues/authors.txt b/core/queues/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/core/queues/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/core/queues/queues-docs.factor b/core/queues/queues-docs.factor deleted file mode 100644 index 845b95ea1f..0000000000 --- a/core/queues/queues-docs.factor +++ /dev/null @@ -1,77 +0,0 @@ -USING: help.markup help.syntax kernel ; -IN: queues - -ARTICLE: "queues" "Queues" -"Last-in-first-out queues are defined in the " { $vocab-link "queues" } " vocabulary." -$nl -"Queues are a class." -{ $subsection queue } -{ $subsection queue? } -{ $subsection } -"Testing queues:" -{ $subsection queue-empty? } -"Adding elements:" -{ $subsection deque } -"Removing elements:" -{ $subsection enque } -{ $subsection clear-queue } -{ $subsection queue-each } -"An example:" -{ $code - " \"q\" set" - "5 \"q\" get enque" - "3 \"q\" get enque" - "7 \"q\" get enque" - "\"q\" get deque ." - " 5" - "\"q\" get deque ." - " 3" - "\"q\" get deque ." - " 7" -} ; - -ABOUT: "queues" - -HELP: queue -{ $class-description "A simple first-in-first-out queue. See " { $link "queues" } "." } ; - -HELP: entry -{ $class-description "The class of entries in a " { $link queue } ". Each entry holds an object and a reference to the next entry." } ; - -HELP: -{ $values { "obj" object } { "entry" entry } } -{ $description "Creates a new queue entry." } -{ $notes "This word is a factor of " { $link enque } "." } ; - -HELP: -{ $values { "queue" queue } } -{ $description "Makes a new queue with no elements." } ; - -HELP: queue-empty? -{ $values { "queue" queue } { "?" "a boolean" } } -{ $description "Tests if a queue contains no elements." } ; - -HELP: deque -{ $values { "queue" queue } { "elt" object } } -{ $description "Removes an element from the front of the queue." } -{ $errors "Throws an " { $link empty-queue-error } " if the queue has no entries." } -{ $side-effects "queue" } ; - -HELP: enque -{ $values { "elt" object } { "queue" queue } } -{ $description "Adds an element to the back of the queue." } -{ $side-effects "queue" } ; - -HELP: empty-queue-error -{ $description "Throws an " { $link empty-queue-error } "." } -{ $error-description "Thrown by " { $link deque } " if the queue has no entries." } ; - -HELP: clear-queue -{ $values { "queue" queue } } -{ $description "Removes all entries from the queue." } -{ $side-effects "queue" } ; - -HELP: queue-each -{ $values { "queue" queue } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } -{ $description "Applies the quotation to each entry in the queue, starting from the least recently added entry, clearing the queue in the process." } -{ $side-effects "queue" } ; diff --git a/core/queues/queues-tests.factor b/core/queues/queues-tests.factor deleted file mode 100644 index d8df256fc0..0000000000 --- a/core/queues/queues-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: kernel math namespaces queues sequences tools.test ; -IN: temporary - - "queue" set - -[ t ] [ "queue" get queue-empty? ] unit-test - -[ ] [ [ 1 2 3 4 5 ] [ "queue" get enque ] each ] unit-test - -[ { 1 2 3 4 5 } ] [ 5 [ drop "queue" get deque ] map ] unit-test - -[ "queue" get deque ] unit-test-fails diff --git a/core/queues/queues.factor b/core/queues/queues.factor deleted file mode 100644 index 0cd05ea8c0..0000000000 --- a/core/queues/queues.factor +++ /dev/null @@ -1,57 +0,0 @@ -! Copyright (C) 2005, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: queues -USING: kernel inspector ; - -TUPLE: entry obj next ; - -: ( obj -- entry ) f entry construct-boa ; - -TUPLE: queue head tail ; - -: ( -- queue ) queue construct-empty ; - -: queue-empty? ( queue -- ? ) queue-head not ; - -: (enque) ( entry queue -- ) - [ set-queue-head ] 2keep set-queue-tail ; - -: clear-queue ( queue -- ) - f swap (enque) ; - -: enque ( elt queue -- ) - >r r> dup queue-empty? [ - (enque) - ] [ - [ queue-tail set-entry-next ] 2keep set-queue-tail - ] if ; - -: clear-entry ( entry -- ) - f over set-entry-obj f swap set-entry-next ; - -: (deque) ( queue -- ) - dup queue-head over queue-tail eq? [ - clear-queue - ] [ - dup queue-head dup entry-next rot set-queue-head - clear-entry - ] if ; - -TUPLE: empty-queue-error ; -: empty-queue-error ( -- * ) - \ empty-queue-error construct-empty throw ; - -: deque ( queue -- elt ) - dup queue-empty? [ - empty-queue-error - ] [ - dup queue-head entry-obj >r (deque) r> - ] if ; - -M: empty-queue-error summary - drop "Empty queue" ; - -: queue-each ( queue quot -- ) - over queue-empty? - [ 2drop ] [ [ >r deque r> call ] 2keep queue-each ] if ; - inline diff --git a/core/queues/summary.txt b/core/queues/summary.txt deleted file mode 100644 index 7bc2a8c7f2..0000000000 --- a/core/queues/summary.txt +++ /dev/null @@ -1 +0,0 @@ -FIFO queues diff --git a/core/queues/tags.txt b/core/queues/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/core/queues/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index b4a7c340ad..ccd25c8e3f 100644 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel kernel.private io -threads.private continuations queues ; +threads.private continuations ; IN: threads ARTICLE: "threads" "Threads" diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 074259dce6..95536db00c 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -2,9 +2,9 @@ ! Copyright (C) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. IN: threads -USING: arrays init hashtables heaps io.backend kernel kernel.private -math namespaces queues sequences vectors io system sorting -continuations debugger ; +USING: arrays init hashtables heaps io.backend kernel +kernel.private math namespaces sequences vectors io system +continuations debugger dlists ; ( obj1 obj2 -- n ) [ sleeping-ms ] 2apply - ; : sleep-time ( -- ms ) - sleep-queue get-global - dup heap-empty? [ drop 1000 ] [ heap-peek sleeping-ms millis [-] ] if ; + sleep-queue get-global dup heap-empty? + [ drop 1000 ] [ heap-peek sleeping-ms millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; @@ -29,7 +29,7 @@ M: sleeping <=> ( obj1 obj2 -- n ) PRIVATE> -: schedule-thread ( continuation -- ) run-queue enque ; +: schedule-thread ( continuation -- ) run-queue push-front ; : schedule-thread-with ( obj continuation -- ) 2array schedule-thread ; @@ -38,7 +38,7 @@ PRIVATE> walker-hook [ f swap continue-with ] [ - run-queue deque dup array? + run-queue pop-back dup array? [ first2 continue-with ] [ continue ] if ] if* ; @@ -64,10 +64,10 @@ PRIVATE> [ 0 ? io-multiplex ] if ; : idle-thread ( -- ) - run-queue queue-empty? (idle-thread) yield idle-thread ; + run-queue dlist-empty? (idle-thread) yield idle-thread ; : init-threads ( -- ) - \ run-queue set-global + \ run-queue set-global sleep-queue set-global [ idle-thread ] in-thread ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 8f20b68cc1..44f932abb2 100644 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -122,14 +122,14 @@ ARTICLE: "collections" "Collections" { $heading "Associative mappings" } { $subsection "assocs" } { $subsection "namespaces" } -{ $subsection "graphs" } "Implementations:" { $subsection "hashtables" } { $subsection "alists" } { $heading "Other collections" } -{ $subsection "buffers" } { $subsection "dlists" } -{ $subsection "heaps" } ; +{ $subsection "heaps" } +{ $subsection "graphs" } +{ $subsection "buffers" } ; USE: io.sockets diff --git a/extra/help/markup/markup-docs.factor b/extra/help/markup/markup-docs.factor index 0af65954e6..f6ef5f8408 100644 --- a/extra/help/markup/markup-docs.factor +++ b/extra/help/markup/markup-docs.factor @@ -100,7 +100,7 @@ HELP: $link { $values { "element" "a markup element of the form " { $snippet "{ topic }" } } } { $description "Prints a link to a help article or word." } { $examples - { $markup-example { $link "queues" } } + { $markup-example { $link "dlists" } } { $markup-example { $link + } } } ; @@ -123,7 +123,7 @@ HELP: $see-also { $values { "topics" "a sequence of article names or words" } } { $description "Prints a heading followed by a series of links." } { $examples - { $markup-example { $see-also "graphs" "queues" } } + { $markup-example { $see-also "graphs" "dlists" } } } ; { $see-also $related related-words } related-words diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index dddab1aa8a..e4d4434b4e 100644 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences -timers quotations math.vectors queues combinators sorting -vectors ; +timers quotations math.vectors combinators sorting vectors +dlists ; IN: ui.gadgets TUPLE: rect loc dim ; @@ -159,7 +159,7 @@ M: array gadget-text* #! When unit testing gadgets without the UI running, the #! invalid queue is not initialized and we simply ignore #! invalidation requests. - invalid [ enque ] [ drop ] if* ; + invalid [ push-front ] [ drop ] if* ; DEFER: relayout diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index c7b4455bc7..0e337c538a 100644 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math models namespaces queues +USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser math.vectors tuples classes ui.gadgets timers ; IN: ui.gestures diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 18886ef348..6ed3aa6d36 100644 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces -prettyprint queues sequences threads sequences words timers +prettyprint dlists sequences threads sequences words timers debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init ; IN: ui @@ -81,7 +81,7 @@ SYMBOL: windows [ invalid [ dup layout find-world [ , ] when* - ] queue-each + ] dlist-slurp ] { } make ; SYMBOL: ui-hook From 7751d49ffedfb1cae5837b3c1abb2ba993f338ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 11:11:48 -0500 Subject: [PATCH 21/26] Doc fixes --- core/dlists/dlists-docs.factor | 2 ++ core/threads/threads-docs.factor | 6 +++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor index a20d038621..5a808a9a5d 100644 --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -6,6 +6,8 @@ ARTICLE: "dlists" "Doubly-linked lists" $nl "While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time." $nl +"When using a dlist as a simple queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "." +$nl "Dlists form a class:" { $subsection dlist } { $subsection dlist? } diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index ccd25c8e3f..181979bfed 100644 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel kernel.private io -threads.private continuations ; +threads.private continuations dlists ; IN: threads ARTICLE: "threads" "Threads" @@ -20,8 +20,8 @@ $nl ABOUT: "threads" HELP: run-queue -{ $values { "queue" queue } } -{ $description "Outputs the runnable thread queue." } ; +{ $values { "queue" dlist } } +{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } " and dequeued with " { $link pop-back } "." } ; HELP: schedule-thread { $values { "continuation" "a continuation reified by " { $link callcc0 } } } From bf32fb7a53342e89e9a6d205af1dd5d933c580fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 11:13:31 -0500 Subject: [PATCH 22/26] Load fix --- extra/ui/ui.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 6ed3aa6d36..fc5777ab6a 100644 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -87,7 +87,7 @@ SYMBOL: windows SYMBOL: ui-hook : init-ui ( -- ) - \ invalid set-global + \ invalid set-global V{ } clone windows set-global ; : start-ui ( -- ) From 29afe48d326623b929e68b5f61a9420529d5758f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 11:10:26 -0600 Subject: [PATCH 23/26] Update heaps to store key/value pairs instead of objects comparable by <=> Update docs Add heap-length --- core/heaps/heaps-docs.factor | 38 +++++++++++++++++++++++------------ core/heaps/heaps-tests.factor | 25 +++++++++++++---------- core/heaps/heaps.factor | 16 ++++++++------- 3 files changed, 48 insertions(+), 31 deletions(-) diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index 3ed2813123..edaa32a6a6 100644 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -4,7 +4,7 @@ IN: heaps ARTICLE: "heaps" "Heaps" "A heap is an implementation of a " { $emphasis "priority queue" } ", which is a structure that maintains a sorted set of elements. The key property is that insertion of an arbitrary element and removal of the first element (determined by order) is performed in O(log n) time." $nl -"Heap elements are compared using the " { $link <=> } " generic word." +"Heap elements are key/value pairs and are compared using the " { $link <=> } " generic word on the first element of the pair." $nl "There are two classes of heaps. Min-heaps sort their elements so that the minimum element is first:" { $subsection min-heap } @@ -18,6 +18,7 @@ $nl $nl "Queries:" { $subsection heap-empty? } +{ $subsection heap-length } { $subsection heap-peek } "Insertion:" { $subsection heap-push } @@ -31,33 +32,44 @@ ABOUT: "heaps" HELP: { $values { "min-heap" min-heap } } { $description "Create a new " { $link min-heap } "." } -; +{ $see-also } ; HELP: { $values { "max-heap" max-heap } } { $description "Create a new " { $link max-heap } "." } -; +{ $see-also } ; HELP: heap-push -{ $values { "obj" "an object" } { "heap" "a heap" } } -{ $description "Push an object onto a heap." } ; +{ $values { "pair" "a key/value pair" } { "heap" "a heap" } } +{ $description "Push an pair onto a heap. The first element of the pair must be comparable to the rest of the heap by the " { $link <=> } " word." } +{ $see-also heap-push-all heap-pop } ; HELP: heap-push-all -{ $values { "seq" "a sequence" } { "heap" "a heap" } } -{ $description "Push a sequence onto a heap." } ; +{ $values { "seq" "a sequence of pairs" } { "heap" "a heap" } } +{ $description "Push a sequence of pairs onto a heap." } +{ $see-also heap-push heap-pop } ; HELP: heap-peek -{ $values { "heap" "a heap" } { "obj" "an object" } } -{ $description "Returns the first element in the heap and leaves it in the heap." } ; +{ $values { "heap" "a heap" } { "pair" "a key/value pair" } } +{ $description "Returns the first element in the heap and leaves it in the heap." } +{ $see-also heap-pop heap-pop* } ; HELP: heap-pop* { $values { "heap" "a heap" } } -{ $description "Removes the first element from the heap." } ; +{ $description "Removes the first element from the heap." } +{ $see-also heap-pop heap-push heap-peek } ; HELP: heap-pop -{ $values { "heap" "a heap" } { "obj" "an object" } } -{ $description "Returns the first element in the heap and removes it from the heap." } ; +{ $values { "heap" "a heap" } { "pair" "an key/value pair" } } +{ $description "Returns the first element in the heap and removes it from the heap." } +{ $see-also heap-pop* heap-push heap-peek } ; HELP: heap-empty? { $values { "heap" "a heap" } { "?" "a boolean" } } -{ $description "Tests if a " { $link heap } " has no nodes." } ; +{ $description "Tests if a " { $link heap } " has no nodes." } +{ $see-also heap-length heap-peek } ; + +HELP: heap-length +{ $values { "heap" "a heap" } { "n" "an integer" } } +{ $description "Returns the number of key/value pairs in the heap." } +{ $see-also heap-empty? } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index befbbc90fc..d326480cb8 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -8,25 +8,28 @@ IN: temporary [ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over heap-push heap-empty? ] unit-test +[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over heap-push heap-empty? ] unit-test +[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test -{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test +{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test +{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test -[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over heap-push-all ] unit-test +[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ] +[ { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test -[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ - { 3 5 4 6 5 7 6 8 } over heap-push-all +[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [ + { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all 3 [ dup heap-pop* ] times ] unit-test -[ 2 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push heap-pop ] unit-test +[ { 2 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push heap-pop ] unit-test -[ 1 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test +[ { 1 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test -[ 400 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test +[ { 400 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test + +[ 0 ] [ heap-length ] unit-test +[ 1 ] [ { 1 t } over heap-push heap-length ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 74ca9e4b34..c92134c25d 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -6,7 +6,7 @@ IN: heaps ( class -- obj ) +: ( class -- heap ) >r V{ } clone heap construct-boa r> construct-delegate ; inline PRIVATE> @@ -29,9 +29,10 @@ TUPLE: max-heap ; : swap-up ( n vec -- ) >r dup up r> exchange ; inline : last-index ( vec -- n ) length 1- ; inline -GENERIC: heap-compare ( obj1 obj2 heap -- ? ) -M: min-heap heap-compare drop <=> 0 > ; -M: max-heap heap-compare drop <=> 0 < ; +GENERIC: heap-compare ( pair1 pair2 heap -- ? ) +: (heap-compare) drop [ first ] 2apply <=> 0 ; inline +M: min-heap heap-compare (heap-compare) > ; +M: max-heap heap-compare (heap-compare) < ; : heap-bounds-check? ( m heap -- ? ) heap-data length >= ; inline @@ -84,12 +85,12 @@ DEFER: down-heap PRIVATE> -: heap-push ( obj heap -- ) +: heap-push ( pair heap -- ) tuck heap-data push [ heap-data ] keep up-heap ; : heap-push-all ( seq heap -- ) [ heap-push ] curry each ; -: heap-peek ( heap -- obj ) heap-data first ; +: heap-peek ( heap -- pair ) heap-data first ; : heap-pop* ( heap -- ) dup heap-data length 1 > [ @@ -100,5 +101,6 @@ PRIVATE> heap-data pop* ] if ; -: heap-pop ( heap -- obj ) [ heap-data first ] keep heap-pop* ; +: heap-pop ( heap -- pair ) [ heap-data first ] keep heap-pop* ; : heap-empty? ( heap -- ? ) heap-data empty? ; +: heap-length ( heap -- n ) heap-data length ; From 478af8e51cd7e20f3c013a291eb64e01033fa078 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 11:11:09 -0600 Subject: [PATCH 24/26] Store ms/continuation pairs in the sleep queue instead of tuples Updated for new heaps --- core/threads/threads.factor | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 95536db00c..b55bec6f85 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -10,22 +10,17 @@ continuations debugger dlists ; SYMBOL: sleep-queue -TUPLE: sleeping ms continuation ; - -M: sleeping <=> ( obj1 obj2 -- n ) - [ sleeping-ms ] 2apply - ; - : sleep-time ( -- ms ) sleep-queue get-global dup heap-empty? - [ drop 1000 ] [ heap-peek sleeping-ms millis [-] ] if ; + [ drop 1000 ] [ heap-peek first millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; : schedule-sleep ( ms continuation -- ) - sleeping construct-boa sleep-queue get-global heap-push ; + 2array sleep-queue get-global heap-push ; : wake-up ( -- continuation ) - sleep-queue get-global heap-pop sleeping-continuation ; + sleep-queue get-global heap-pop second ; PRIVATE> From d481f1480cd9df379f46407aca539115c7a10543 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 12:35:44 -0500 Subject: [PATCH 25/26] Further heap cleanups --- core/heaps/heaps-docs.factor | 22 +++++++++++----------- core/heaps/heaps-tests.factor | 12 ++++++------ core/heaps/heaps.factor | 33 ++++++++++++++++++++++++--------- core/none/deploy.factor | 13 +++++++++++++ core/threads/threads.factor | 13 +++++++------ 5 files changed, 61 insertions(+), 32 deletions(-) create mode 100644 core/none/deploy.factor diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index edaa32a6a6..b140b418aa 100644 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -1,4 +1,4 @@ -USING: heaps.private help.markup help.syntax kernel ; +USING: heaps.private help.markup help.syntax kernel math ; IN: heaps ARTICLE: "heaps" "Heaps" @@ -40,36 +40,36 @@ HELP: { $see-also } ; HELP: heap-push -{ $values { "pair" "a key/value pair" } { "heap" "a heap" } } -{ $description "Push an pair onto a heap. The first element of the pair must be comparable to the rest of the heap by the " { $link <=> } " word." } +{ $values { "key" "a comparable object" } { "value" object } { "heap" } } +{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } { $see-also heap-push-all heap-pop } ; HELP: heap-push-all -{ $values { "seq" "a sequence of pairs" } { "heap" "a heap" } } +{ $values { "seq" "a sequence of pairs" } { "heap" } } { $description "Push a sequence of pairs onto a heap." } { $see-also heap-push heap-pop } ; HELP: heap-peek -{ $values { "heap" "a heap" } { "pair" "a key/value pair" } } -{ $description "Returns the first element in the heap and leaves it in the heap." } +{ $values { "heap" } { "key" object } { "value" object } } +{ $description "Outputs the first element in the heap, leaving it in the heap." } { $see-also heap-pop heap-pop* } ; HELP: heap-pop* -{ $values { "heap" "a heap" } } +{ $values { "heap" } } { $description "Removes the first element from the heap." } { $see-also heap-pop heap-push heap-peek } ; HELP: heap-pop -{ $values { "heap" "a heap" } { "pair" "an key/value pair" } } -{ $description "Returns the first element in the heap and removes it from the heap." } +{ $values { "heap" } { "key" object } { "value" object } } +{ $description "Outputs the first element in the heap and removes it from the heap." } { $see-also heap-pop* heap-push heap-peek } ; HELP: heap-empty? -{ $values { "heap" "a heap" } { "?" "a boolean" } } +{ $values { "heap" } { "?" "a boolean" } } { $description "Tests if a " { $link heap } " has no nodes." } { $see-also heap-length heap-peek } ; HELP: heap-length -{ $values { "heap" "a heap" } { "n" "an integer" } } +{ $values { "heap" } { "n" integer } } { $description "Returns the number of key/value pairs in the heap." } { $see-also heap-empty? } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index d326480cb8..68e667d80e 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -8,9 +8,9 @@ IN: temporary [ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test +[ f ] [ 1 t pick heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test +[ f ] [ 1 t pick heap-push heap-empty? ] unit-test ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test @@ -25,11 +25,11 @@ IN: temporary 3 [ dup heap-pop* ] times ] unit-test -[ { 2 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push heap-pop ] unit-test +[ 2 t ] [ 300 t pick heap-push 200 t pick heap-push 400 t pick heap-push 3 t pick heap-push 2 t pick heap-push heap-pop ] unit-test -[ { 1 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test +[ 1 t ] [ 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test -[ { 400 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test +[ 400 t ] [ 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test [ 0 ] [ heap-length ] unit-test -[ 1 ] [ { 1 t } over heap-push heap-length ] unit-test +[ 1 ] [ 1 1 pick heap-push heap-length ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index c92134c25d..14d3e20a60 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Ryan Murphy, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; +USING: kernel math sequences arrays assocs ; IN: heaps 0 ; inline +: (heap-compare) drop [ first ] compare 0 ; inline M: min-heap heap-compare (heap-compare) > ; M: max-heap heap-compare (heap-compare) < ; : heap-bounds-check? ( m heap -- ? ) heap-data length >= ; inline - + : left-bounds-check? ( m heap -- ? ) >r left r> heap-bounds-check? ; inline @@ -72,7 +72,7 @@ DEFER: down-heap : down-heap-continue? ( heap m heap -- m heap ? ) [ heap-data nth ] 2keep child pick dupd [ heap-data nth swapd ] keep heap-compare ; - + : (down-heap) ( m heap -- ) 2dup down-heap-continue? [ -rot [ swap-down ] keep down-heap @@ -85,12 +85,17 @@ DEFER: down-heap PRIVATE> -: heap-push ( pair heap -- ) - tuck heap-data push [ heap-data ] keep up-heap ; +: heap-push ( value key heap -- ) + >r swap 2array r> + [ heap-data push ] keep + [ heap-data ] keep + up-heap ; -: heap-push-all ( seq heap -- ) [ heap-push ] curry each ; +: heap-push-all ( assoc heap -- ) + [ swap heap-push ] curry assoc-each ; -: heap-peek ( heap -- pair ) heap-data first ; +: heap-peek ( heap -- value key ) + heap-data first first2 swap ; : heap-pop* ( heap -- ) dup heap-data length 1 > [ @@ -101,6 +106,16 @@ PRIVATE> heap-data pop* ] if ; -: heap-pop ( heap -- pair ) [ heap-data first ] keep heap-pop* ; +: heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; + : heap-empty? ( heap -- ? ) heap-data empty? ; + : heap-length ( heap -- n ) heap-data length ; + +: heap-pop-all ( heap -- seq ) + [ dup heap-empty? not ] + [ dup heap-pop drop ] + [ ] unfold nip ; + +: heap-sort ( assoc -- seq ) + tuck heap-push-all heap-pop-all ; diff --git a/core/none/deploy.factor b/core/none/deploy.factor new file mode 100644 index 0000000000..f604beab3f --- /dev/null +++ b/core/none/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy.config ; +H{ + { deploy-math? f } + { deploy-word-defs? f } + { deploy-word-props? f } + { deploy-name "none" } + { "stop-after-last-window?" t } + { deploy-c-types? f } + { deploy-compiler? f } + { deploy-io 1 } + { deploy-ui? f } + { deploy-reflection 1 } +} diff --git a/core/threads/threads.factor b/core/threads/threads.factor index b55bec6f85..7a67d1b531 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -12,19 +12,20 @@ SYMBOL: sleep-queue : sleep-time ( -- ms ) sleep-queue get-global dup heap-empty? - [ drop 1000 ] [ heap-peek first millis [-] ] if ; + [ drop 1000 ] [ heap-peek nip millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; -: schedule-sleep ( ms continuation -- ) - 2array sleep-queue get-global heap-push ; +: schedule-sleep ( continuation ms -- ) + sleep-queue get-global heap-push ; : wake-up ( -- continuation ) - sleep-queue get-global heap-pop second ; + sleep-queue get-global heap-pop drop ; PRIVATE> -: schedule-thread ( continuation -- ) run-queue push-front ; +: schedule-thread ( continuation -- ) + run-queue push-front ; : schedule-thread-with ( obj continuation -- ) 2array schedule-thread ; @@ -40,7 +41,7 @@ PRIVATE> : yield ( -- ) [ schedule-thread stop ] callcc0 ; : sleep ( ms -- ) - >fixnum millis + [ schedule-sleep stop ] callcc0 drop ; + >fixnum millis + [ schedule-sleep stop ] curry callcc0 ; : in-thread ( quot -- ) [ From 855c444ec50dcb03d836e12c089cc63a3302b203 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 12:48:22 -0500 Subject: [PATCH 26/26] Heap unit test fixes --- core/heaps/heaps-docs.factor | 24 ++++++++++++++---------- core/heaps/heaps-tests.factor | 8 ++++---- core/heaps/heaps.factor | 10 +--------- 3 files changed, 19 insertions(+), 23 deletions(-) diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index b140b418aa..3605ec519a 100644 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -1,4 +1,4 @@ -USING: heaps.private help.markup help.syntax kernel math ; +USING: heaps.private help.markup help.syntax kernel math assocs ; IN: heaps ARTICLE: "heaps" "Heaps" @@ -40,36 +40,40 @@ HELP: { $see-also } ; HELP: heap-push -{ $values { "key" "a comparable object" } { "value" object } { "heap" } } +{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } } { $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } +{ $side-effects "heap" } { $see-also heap-push-all heap-pop } ; HELP: heap-push-all -{ $values { "seq" "a sequence of pairs" } { "heap" } } -{ $description "Push a sequence of pairs onto a heap." } -{ $see-also heap-push heap-pop } ; +{ $values { "assoc" assoc } { "heap" heap } } +{ $description "Push every key/value pair of an assoc onto a heap." } +{ $side-effects "heap" } +{ $see-also heap-push heap-pop } ; HELP: heap-peek -{ $values { "heap" } { "key" object } { "value" object } } +{ $values { "heap" heap } { "key" object } { "value" object } } { $description "Outputs the first element in the heap, leaving it in the heap." } { $see-also heap-pop heap-pop* } ; HELP: heap-pop* -{ $values { "heap" } } +{ $values { "heap" heap } } { $description "Removes the first element from the heap." } +{ $side-effects "heap" } { $see-also heap-pop heap-push heap-peek } ; HELP: heap-pop -{ $values { "heap" } { "key" object } { "value" object } } +{ $values { "heap" heap } { "key" object } { "value" object } } { $description "Outputs the first element in the heap and removes it from the heap." } +{ $side-effects "heap" } { $see-also heap-pop* heap-push heap-peek } ; HELP: heap-empty? -{ $values { "heap" } { "?" "a boolean" } } +{ $values { "heap" heap } { "?" "a boolean" } } { $description "Tests if a " { $link heap } " has no nodes." } { $see-also heap-length heap-peek } ; HELP: heap-length -{ $values { "heap" } { "n" integer } } +{ $values { "heap" heap } { "n" integer } } { $description "Returns the number of key/value pairs in the heap." } { $see-also heap-empty? } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 68e667d80e..03e0816c19 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -25,11 +25,11 @@ IN: temporary 3 [ dup heap-pop* ] times ] unit-test -[ 2 t ] [ 300 t pick heap-push 200 t pick heap-push 400 t pick heap-push 3 t pick heap-push 2 t pick heap-push heap-pop ] unit-test +[ t 2 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test -[ 1 t ] [ 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test +[ t 1 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test -[ 400 t ] [ 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test +[ t 400 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test [ 0 ] [ heap-length ] unit-test -[ 1 ] [ 1 1 pick heap-push heap-length ] unit-test +[ 1 ] [ t 1 pick heap-push heap-length ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 14d3e20a60..73a37660f6 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -92,7 +92,7 @@ PRIVATE> up-heap ; : heap-push-all ( assoc heap -- ) - [ swap heap-push ] curry assoc-each ; + [ swapd heap-push ] curry assoc-each ; : heap-peek ( heap -- value key ) heap-data first first2 swap ; @@ -111,11 +111,3 @@ PRIVATE> : heap-empty? ( heap -- ? ) heap-data empty? ; : heap-length ( heap -- n ) heap-data length ; - -: heap-pop-all ( heap -- seq ) - [ dup heap-empty? not ] - [ dup heap-pop drop ] - [ ] unfold nip ; - -: heap-sort ( assoc -- seq ) - tuck heap-push-all heap-pop-all ;