From ee6443053bbdac17785f6c074a5de446365cd3bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 6 Jul 2008 19:39:53 -0700 Subject: [PATCH 01/73] Remove useless bitand from integer>bit-array; set-alien-unsigned-1 does that for us! --- extra/bit-arrays/bit-arrays.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/bit-arrays/bit-arrays.factor b/extra/bit-arrays/bit-arrays.factor index 3d699a2623..4e6f7428b0 100755 --- a/extra/bit-arrays/bit-arrays.factor +++ b/extra/bit-arrays/bit-arrays.factor @@ -76,7 +76,7 @@ M: bit-array byte-length length 7 + -3 shift ; n zero? [ 0 ] [ [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | [ n' zero? not ] [ - n' out underlying>> i 255 bitand set-alien-unsigned-1 + n' out underlying>> i set-alien-unsigned-1 n' -8 shift n'! i 1+ i! ] [ ] while From 2f560ffbe0ac1dc1eaad61774698b7b80ba91c0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 17:46:57 -0500 Subject: [PATCH 02/73] Fix typo --- core/classes/tuple/tuple-docs.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 114146e450..51c175a282 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -298,16 +298,16 @@ $nl "For example, compare the definitions of the " { $link sbuf } " class," { $code "TUPLE: sbuf" - "{ \"underlying\" string }" - "{ \"length\" array-capacity } ;" + "{ underlying string }" + "{ length array-capacity } ;" "" "INSTANCE: sbuf growable" } "with that of the " { $link vector } " class:" { $code "TUPLE: vector" - "{ \"underlying\" array }" - "{ \"length\" array-capacity } ;" + "{ underlying array }" + "{ length array-capacity } ;" "" "INSTANCE: vector growable" } ; From 1026587d631263942a4a5e6491fb944ffa2f46c6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:07:04 -0500 Subject: [PATCH 03/73] add math.geometry.rect --- extra/math/geometry/rect/rect.factor | 42 ++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 extra/math/geometry/rect/rect.factor diff --git a/extra/math/geometry/rect/rect.factor b/extra/math/geometry/rect/rect.factor new file mode 100644 index 0000000000..51f42c22ca --- /dev/null +++ b/extra/math/geometry/rect/rect.factor @@ -0,0 +1,42 @@ + +USING: kernel arrays math.vectors ; + +IN: math.geometry.rect + +TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; + +: ( -- rect ) rect new ; + +C: rect + +M: array rect-loc ; + +M: array rect-dim drop { 0 0 } ; + +: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ; + +: rect-extent ( rect -- loc ext ) rect-bounds over v+ ; + +: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 ) + [ rect-extent ] bi@ swapd ; + +: ( loc ext -- rect ) over [v-] ; + +: offset-rect ( rect loc -- newrect ) + over rect-loc v+ swap rect-dim ; + +: (rect-intersect) ( rect rect -- array array ) + 2rect-extent vmin >r vmax r> ; + +: rect-intersect ( rect1 rect2 -- newrect ) + (rect-intersect) ; + +: intersects? ( rect/point rect -- ? ) + (rect-intersect) [v-] { 0 0 } = ; + +: (rect-union) ( rect rect -- array array ) + 2rect-extent vmax >r vmin r> ; + +: rect-union ( rect1 rect2 -- newrect ) + (rect-union) ; + From 6235d0b16f7e1c0394461225cd235e557764dd48 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:13:41 -0500 Subject: [PATCH 04/73] gadgets: remove rect (moved to math.geometry.rect) --- extra/ui/gadgets/gadgets.factor | 43 +++------------------------------ 1 file changed, 4 insertions(+), 39 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 5bfb5a1b05..a274dc2392 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,51 +1,16 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables kernel models math namespaces -sequences quotations math.vectors combinators sorting vectors -dlists dequeues models threads concurrency.flags math.order ; + sequences quotations math.vectors combinators sorting vectors + dlists dequeues models threads concurrency.flags + math.order math.geometry.rect ; + IN: ui.gadgets SYMBOL: ui-notify-flag : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; -TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; - -: ( -- rect ) rect new ; - -C: rect - -M: array rect-loc ; - -M: array rect-dim drop { 0 0 } ; - -: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ; - -: rect-extent ( rect -- loc ext ) rect-bounds over v+ ; - -: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 ) - [ rect-extent ] bi@ swapd ; - -: ( loc ext -- rect ) over [v-] ; - -: offset-rect ( rect loc -- newrect ) - over rect-loc v+ swap rect-dim ; - -: (rect-intersect) ( rect rect -- array array ) - 2rect-extent vmin >r vmax r> ; - -: rect-intersect ( rect1 rect2 -- newrect ) - (rect-intersect) ; - -: intersects? ( rect/point rect -- ? ) - (rect-intersect) [v-] { 0 0 } = ; - -: (rect-union) ( rect rect -- array array ) - 2rect-extent vmax >r vmin r> ; - -: rect-union ( rect1 rect2 -- newrect ) - (rect-union) ; - TUPLE: gadget < rect pref-dim parent children orientation focus visible? root? clipped? layout-state graft-state graft-node From e0602a621d9e2f72d1d8e3847eaf54d263f3b2d1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:14:05 -0500 Subject: [PATCH 05/73] add math.geometry.rect-docs --- extra/math/geometry/rect/rect-docs.factor | 54 +++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 extra/math/geometry/rect/rect-docs.factor diff --git a/extra/math/geometry/rect/rect-docs.factor b/extra/math/geometry/rect/rect-docs.factor new file mode 100644 index 0000000000..3e21dfe307 --- /dev/null +++ b/extra/math/geometry/rect/rect-docs.factor @@ -0,0 +1,54 @@ +USING: help.markup help.syntax ; + +IN: math.geometry.rect + +HELP: rect +{ $class-description "A rectangle with the following slots:" + { $list + { { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" } + { { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" } + } + "Rectangles are constructed by calling " { $link } " and " { $link } "." +} ; + +HELP: ( loc dim -- rect ) +{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } } +{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ; + +{ } related-words + +HELP: set-rect-dim ( dim rect -- ) +{ $values { "dim" "a pair of integers" } { "rect" rect } } +{ $description "Modifies the dimensions of a rectangle." } +{ $side-effects "rect" } ; + +HELP: rect-bounds +{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } } +{ $description "Outputs the location and dimensions of a rectangle." } ; + +{ rect-bounds rect-extent } related-words + +HELP: ( loc ext -- rect ) +{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } } +{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ; + +HELP: rect-extent +{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } } +{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ; + +HELP: offset-rect +{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } } +{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ; + +HELP: rect-intersect +{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } } +{ $description "Computes the intersection of two rectangles." } ; + +HELP: intersects? +{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } } +{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ; + +HELP: +{ $values { "rect" "a new " { $link rect } } } +{ $description "Creates a rectangle located at the origin with zero dimensions." } ; + From 6a358bd391231601e6854761afbd7530e6777d84 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:14:30 -0500 Subject: [PATCH 06/73] gadgets-docs: remove rect help --- extra/ui/gadgets/gadgets-docs.factor | 52 +--------------------------- 1 file changed, 1 insertion(+), 51 deletions(-) diff --git a/extra/ui/gadgets/gadgets-docs.factor b/extra/ui/gadgets/gadgets-docs.factor index 8093aa5dc5..b9d12847be 100755 --- a/extra/ui/gadgets/gadgets-docs.factor +++ b/extra/ui/gadgets/gadgets-docs.factor @@ -1,53 +1,7 @@ USING: help.markup help.syntax opengl kernel strings -classes.tuple classes quotations models ; + classes.tuple classes quotations models math.geometry.rect ; IN: ui.gadgets -HELP: rect -{ $class-description "A rectangle with the following slots:" - { $list - { { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" } - { { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" } - } - "Rectangles are constructed by calling " { $link } " and " { $link } "." -} ; - -HELP: ( loc dim -- rect ) -{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } } -{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ; - -{ } related-words - -HELP: set-rect-dim ( dim rect -- ) -{ $values { "dim" "a pair of integers" } { "rect" rect } } -{ $description "Modifies the dimensions of a rectangle. To resize a gadget, use " { $link set-gadget-dim } " or " { $link set-layout-dim } " instead." } -{ $side-effects "rect" } ; - -HELP: rect-bounds -{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } } -{ $description "Outputs the location and dimensions of a rectangle." } ; - -{ rect-bounds rect-extent } related-words - -HELP: ( loc ext -- rect ) -{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } } -{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ; - -HELP: rect-extent -{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } } -{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ; - -HELP: offset-rect -{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } } -{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ; - -HELP: rect-intersect -{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } } -{ $description "Computes the intersection of two rectangles." } ; - -HELP: intersects? -{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } } -{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ; - HELP: gadget-child { $values { "gadget" gadget } { "child" gadget } } { $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ; @@ -57,10 +11,6 @@ HELP: nth-gadget { $description "Outputs the " { $snippet "n" } "th child of the gadget." } { $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ; -HELP: -{ $values { "rect" "a new " { $link rect } } } -{ $description "Creates a rectangle located at the origin with zero dimensions." } ; - HELP: { $values { "gadget" "a new " { $link gadget } } } { $description "Creates a new gadget." } ; From 75991cf7ce74bc391a8feff753dc4785e2703f80 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:34:43 -0500 Subject: [PATCH 07/73] Edit USING: for 'math.geometry.rect' --- extra/ui/gadgets/books/books.factor | 2 +- extra/ui/gadgets/borders/borders.factor | 2 +- extra/ui/gadgets/buttons/buttons.factor | 2 +- extra/ui/gadgets/editors/editors.factor | 3 ++- extra/ui/gadgets/frames/frames.factor | 3 ++- extra/ui/gadgets/grid-lines/grid-lines.factor | 2 +- extra/ui/gadgets/grids/grids.factor | 3 ++- extra/ui/gadgets/incremental/incremental.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 2 +- extra/ui/gadgets/menus/menus.factor | 3 ++- extra/ui/gadgets/packs/packs.factor | 2 +- extra/ui/gadgets/panes/panes.factor | 2 +- extra/ui/gadgets/paragraphs/paragraphs.factor | 2 +- extra/ui/gadgets/scrollers/scrollers-docs.factor | 2 +- extra/ui/gadgets/scrollers/scrollers.factor | 2 +- extra/ui/gadgets/sliders/sliders.factor | 2 +- extra/ui/gadgets/tracks/tracks.factor | 2 +- extra/ui/gadgets/viewports/viewports.factor | 2 +- extra/ui/gadgets/worlds/worlds.factor | 2 +- extra/ui/render/render-docs.factor | 2 +- extra/ui/render/render.factor | 3 ++- extra/ui/ui-docs.factor | 2 +- extra/ui/x11/x11.factor | 2 +- 23 files changed, 28 insertions(+), 23 deletions(-) diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index 219a970943..93a8d271af 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences models ui.gadgets ; +USING: accessors kernel sequences models ui.gadgets math.geometry.rect ; IN: ui.gadgets.books TUPLE: book < gadget ; diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 55d1993b1d..2c232392ce 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays ui.gadgets kernel math -namespaces vectors sequences math.vectors ; +namespaces vectors sequences math.vectors math.geometry.rect ; IN: ui.gadgets.borders TUPLE: border < gadget diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 96a89e8aa6..a855a6d93e 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -6,7 +6,7 @@ classes.tuple opengl math.vectors ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures -ui.render ; +ui.render math.geometry.rect ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 1732d404ca..8b0244900a 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -5,7 +5,8 @@ namespaces opengl opengl.gl sequences strings io.styles math.vectors sorting colors combinators assocs math.order ui.clipboards ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ; +ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures +math.geometry.rect ; IN: ui.gadgets.editors TUPLE: editor < gadget diff --git a/extra/ui/gadgets/frames/frames.factor b/extra/ui/gadgets/frames/frames.factor index 096d916a9b..717323c69a 100644 --- a/extra/ui/gadgets/frames/frames.factor +++ b/extra/ui/gadgets/frames/frames.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel math namespaces sequences words -splitting grouping math.vectors ui.gadgets.grids ui.gadgets ; +splitting grouping math.vectors ui.gadgets.grids ui.gadgets +math.geometry.rect ; IN: ui.gadgets.frames ! A frame arranges gadgets in a 3x3 grid, where the center diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor index 533116824b..d0cedc985b 100755 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces opengl opengl.gl sequences -math.vectors ui.gadgets ui.gadgets.grids ui.render ; +math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ; IN: ui.gadgets.grid-lines TUPLE: grid-lines color ; diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor index 70aee4d1e3..b539934771 100644 --- a/extra/ui/gadgets/grids/grids.factor +++ b/extra/ui/gadgets/grids/grids.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces sequences words io -io.streams.string math.vectors ui.gadgets columns accessors ; +io.streams.string math.vectors ui.gadgets columns accessors +math.geometry.rect ; IN: ui.gadgets.grids TUPLE: grid < gadget diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index 418dd3b7c6..c74f6676ad 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math namespaces math.vectors ui.gadgets -ui.gadgets.packs accessors ; +ui.gadgets.packs accessors math.geometry.rect ; IN: ui.gadgets.incremental ! Incremental layout allows adding lines to panes to be O(1). diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 2b50453cf4..776814853f 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -4,7 +4,7 @@ USING: accessors ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels ui.gadgets.scrollers kernel sequences models opengl math math.order namespaces ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs -math.vectors classes.tuple ; +math.vectors classes.tuple math.geometry.rect ; IN: ui.gadgets.lists TUPLE: list < pack index presenter color hook ; diff --git a/extra/ui/gadgets/menus/menus.factor b/extra/ui/gadgets/menus/menus.factor index 66dbb05d66..3e1145a8b6 100644 --- a/extra/ui/gadgets/menus/menus.factor +++ b/extra/ui/gadgets/menus/menus.factor @@ -3,7 +3,8 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic hashtables kernel math models namespaces opengl sequences math.vectors -ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors ; +ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors +math.geometry.rect ; IN: ui.gadgets.menus : menu-loc ( world menu -- loc ) diff --git a/extra/ui/gadgets/packs/packs.factor b/extra/ui/gadgets/packs/packs.factor index 00f27af270..7ae222c279 100755 --- a/extra/ui/gadgets/packs/packs.factor +++ b/extra/ui/gadgets/packs/packs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences ui.gadgets kernel math math.functions -math.vectors namespaces math.order accessors ; +math.vectors namespaces math.order accessors math.geometry.rect ; IN: ui.gadgets.packs TUPLE: pack < gadget diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 87eec35871..973c8c5725 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -9,7 +9,7 @@ quotations math opengl combinators math.vectors sorting splitting io.streams.nested assocs ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines classes.tuple models continuations -destructors accessors ; +destructors accessors math.geometry.rect ; IN: ui.gadgets.panes TUPLE: pane < pack diff --git a/extra/ui/gadgets/paragraphs/paragraphs.factor b/extra/ui/gadgets/paragraphs/paragraphs.factor index 12382be9cd..1946ff6db6 100644 --- a/extra/ui/gadgets/paragraphs/paragraphs.factor +++ b/extra/ui/gadgets/paragraphs/paragraphs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math -namespaces sequences math.order ; +namespaces sequences math.order math.geometry.rect ; IN: ui.gadgets.paragraphs ! A word break gadget diff --git a/extra/ui/gadgets/scrollers/scrollers-docs.factor b/extra/ui/gadgets/scrollers/scrollers-docs.factor index ee82339f33..3554c735a7 100755 --- a/extra/ui/gadgets/scrollers/scrollers-docs.factor +++ b/extra/ui/gadgets/scrollers/scrollers-docs.factor @@ -1,5 +1,5 @@ USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports -ui.gadgets.sliders ; +ui.gadgets.sliders math.geometry.rect ; IN: ui.gadgets.scrollers HELP: scroller diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index 8cac3f4400..1fe3c606bb 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -4,7 +4,7 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math namespaces sequences models models.range models.compose -combinators math.vectors classes.tuple ; +combinators math.vectors classes.tuple math.geometry.rect ; IN: ui.gadgets.scrollers TUPLE: scroller < frame viewport x y follows ; diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor index da18dea142..b5d8862359 100755 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids math.order ui.gadgets.theme ui.render kernel math namespaces sequences vectors models models.range math.vectors math.functions -quotations colors ; +quotations colors math.geometry.rect ; IN: ui.gadgets.sliders TUPLE: elevator < gadget direction ; diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index f9276fd1a1..5de9b9d366 100644 --- a/extra/ui/gadgets/tracks/tracks.factor +++ b/extra/ui/gadgets/tracks/tracks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors io kernel math namespaces -sequences words math.vectors ui.gadgets ui.gadgets.packs ; +sequences words math.vectors ui.gadgets ui.gadgets.packs math.geometry.rect ; IN: ui.gadgets.tracks TUPLE: track < pack sizes ; diff --git a/extra/ui/gadgets/viewports/viewports.factor b/extra/ui/gadgets/viewports/viewports.factor index 2e7e130404..100d6c8a39 100755 --- a/extra/ui/gadgets/viewports/viewports.factor +++ b/extra/ui/gadgets/viewports/viewports.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: ui.gadgets.viewports USING: accessors arrays ui.gadgets ui.gadgets.borders -kernel math namespaces sequences models math.vectors ; +kernel math namespaces sequences models math.vectors math.geometry.rect ; : viewport-gap { 3 3 } ; inline diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index 7064045cc4..dc4debd900 100755 --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl sequences io combinators math.vectors ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -debugger ; +debugger math.geometry.rect ; IN: ui.gadgets.worlds TUPLE: world < track diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor index d48d7c99d9..0133b7bb1c 100755 --- a/extra/ui/render/render-docs.factor +++ b/extra/ui/render/render-docs.factor @@ -1,5 +1,5 @@ USING: ui.gadgets ui.gestures help.markup help.syntax -kernel classes strings opengl.gl models ; +kernel classes strings opengl.gl models math.geometry.rect ; IN: ui.render HELP: gadget diff --git a/extra/ui/render/render.factor b/extra/ui/render/render.factor index 8f40bec1c3..6e9a4778a7 100644 --- a/extra/ui/render/render.factor +++ b/extra/ui/render/render.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays hashtables io kernel math namespaces opengl opengl.gl opengl.glu sequences strings io.styles vectors -combinators math.vectors ui.gadgets colors math.order ; +combinators math.vectors ui.gadgets colors +math.order math.geometry.rect ; IN: ui.render SYMBOL: clip diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor index 1a541090c5..72cb2c557e 100755 --- a/extra/ui/ui-docs.factor +++ b/extra/ui/ui-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax strings quotations debugger io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds -ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ; +ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ; IN: ui HELP: windows diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 35f22ec64f..b75daf89fa 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -6,7 +6,7 @@ assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows io.encodings.string io.encodings.ascii io.encodings.utf8 combinators debugger command-line qualified -math.vectors classes.tuple opengl.gl threads ; +math.vectors classes.tuple opengl.gl threads math.geometry.rect ; QUALIFIED: system IN: ui.x11 From 24a063ea76ba94acb3da4cbaad61aaf4c0a606c9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 19:02:43 -0500 Subject: [PATCH 08/73] math.physics.pos and math.physics.vel --- extra/math/physics/pos/pos.factor | 5 +++++ extra/math/physics/vel/vel.factor | 7 +++++++ 2 files changed, 12 insertions(+) create mode 100644 extra/math/physics/pos/pos.factor create mode 100644 extra/math/physics/vel/vel.factor diff --git a/extra/math/physics/pos/pos.factor b/extra/math/physics/pos/pos.factor new file mode 100644 index 0000000000..1582c42108 --- /dev/null +++ b/extra/math/physics/pos/pos.factor @@ -0,0 +1,5 @@ + +IN: math.physics.pos + +TUPLE: pos pos ; + diff --git a/extra/math/physics/vel/vel.factor b/extra/math/physics/vel/vel.factor new file mode 100644 index 0000000000..5fc815e9b8 --- /dev/null +++ b/extra/math/physics/vel/vel.factor @@ -0,0 +1,7 @@ + +USING: math.physics.pos ; + +IN: math.physics.vel + +TUPLE: vel < pos vel ; + From b7b17ed879f63f57efb983f47ca613be24c837f5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 19:03:15 -0500 Subject: [PATCH 09/73] boids: Use math.physics --- extra/boids/boids.factor | 25 ++++++++++++++----------- extra/boids/ui/ui.factor | 7 ++++--- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index e6c97b90dd..cff33c9d19 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -6,14 +6,17 @@ USING: combinators.short-circuit kernel namespaces math.order math.vectors math.trig + math.physics.pos + math.physics.vel combinators arrays sequences random vars - combinators.lib ; + combinators.lib + accessors ; IN: boids ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: boid pos vel ; +TUPLE: boid < vel ; C: boid @@ -70,7 +73,7 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: distance ( boid boid -- n ) [ boid-pos ] [ boid-pos ] bi* v- norm ; +: distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -81,10 +84,10 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ; +: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ; : relative-angle ( self other -- angle ) -over boid-vel -rot relative-position angle-between ; +over vel>> -rot relative-position angle-between ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -92,9 +95,9 @@ over boid-vel -rot relative-position angle-between ; : vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ; -: average-position ( boids -- pos ) [ boid-pos ] map vaverage ; +: average-position ( boids -- pos ) [ pos>> ] map vaverage ; -: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ; +: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -123,7 +126,7 @@ over boid-vel -rot relative-position angle-between ; dup cohesion-neighborhood dup empty? [ 2drop { 0 0 } ] - [ average-position swap boid-pos v- normalize* cohesion-weight> v*n ] + [ average-position swap pos>> v- normalize* cohesion-weight> v*n ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -143,7 +146,7 @@ over boid-vel -rot relative-position angle-between ; dup separation-neighborhood dup empty? [ 2drop { 0 0 } ] - [ average-position swap boid-pos swap v- normalize* separation-weight> v*n ] + [ average-position swap pos>> swap v- normalize* separation-weight> v*n ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -206,10 +209,10 @@ cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: new-pos ( boid -- pos ) [ boid-pos ] [ boid-vel time-slice> v*n ] bi v+ ; +: new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ; : new-vel ( boid -- vel ) - [ boid-vel ] [ acceleration time-slice> v*n ] bi v+ normalize* ; + [ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ; : wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ; diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index e3c54e0744..ab1f8e5f80 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -19,7 +19,8 @@ USING: combinators.short-circuit kernel namespaces ui.gadgets.packs ui.gadgets.grids ui.gestures - assocs.lib vars rewrite-closures boids ; + assocs.lib vars rewrite-closures boids accessors + math.geometry.rect ; IN: boids.ui @@ -27,9 +28,9 @@ IN: boids.ui ! draw-boid ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: point-a ( boid -- a ) boid-pos ; +: point-a ( boid -- a ) pos>> ; -: point-b ( boid -- b ) [ boid-pos ] [ boid-vel normalize* 20 v*n ] bi v+ ; +: point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ; : boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ; From ba6d70b7f728adbf2c55cc6cd9b3853ef45e1753 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 19:28:48 -0500 Subject: [PATCH 10/73] springies: use math.physics --- extra/springies/springies.factor | 69 ++++++++++++++++++-------------- extra/springies/ui/ui.factor | 6 +-- 2 files changed, 42 insertions(+), 33 deletions(-) diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index 1856115863..2640423eb4 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -1,6 +1,6 @@ USING: kernel combinators sequences arrays math math.vectors - generalizations vars ; + generalizations vars accessors math.physics.vel ; IN: springies @@ -28,23 +28,27 @@ VAR: gravity ! node ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: node mass elas pos vel force ; +! TUPLE: node mass elas pos vel force ; + +TUPLE: node < vel mass elas force ; C: node -: >>pos ( node pos -- node ) over set-node-pos ; +! : >>pos ( node pos -- node ) over set-node-pos ; -: >>vel ( node vel -- node ) over set-node-vel ; +! : >>vel ( node vel -- node ) over set-node-vel ; -: pos-x ( node -- x ) node-pos first ; -: pos-y ( node -- y ) node-pos second ; -: vel-x ( node -- y ) node-vel first ; -: vel-y ( node -- y ) node-vel second ; +: set-node-vel ( vel node -- ) swap >>vel drop ; -: >>pos-x ( node x -- node ) over node-pos set-first ; -: >>pos-y ( node y -- node ) over node-pos set-second ; -: >>vel-x ( node x -- node ) over node-vel set-first ; -: >>vel-y ( node y -- node ) over node-vel set-second ; +: pos-x ( node -- x ) pos>> first ; +: pos-y ( node -- y ) pos>> second ; +: vel-x ( node -- y ) vel>> first ; +: vel-y ( node -- y ) vel>> second ; + +: >>pos-x ( node x -- node ) over pos>> set-first ; +: >>pos-y ( node y -- node ) over pos>> set-second ; +: >>vel-x ( node x -- node ) over vel>> set-first ; +: >>vel-y ( node y -- node ) over vel>> set-second ; : apply-force ( node vec -- ) over node-force v+ swap set-node-force ; @@ -61,7 +65,7 @@ TUPLE: spring rest-length k damp node-a node-b ; C: spring : end-points ( spring -- b-pos a-pos ) - [ spring-node-b node-pos ] [ spring-node-a node-pos ] bi ; + [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi ; : spring-length ( spring -- length ) end-points v- norm ; @@ -112,10 +116,10 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-a ( spring -- vel ) - [ spring-node-a node-vel ] [ spring-node-b node-vel ] bi v- ; + [ spring-node-a vel>> ] [ spring-node-b vel>> ] bi v- ; : unit-vec-b->a ( spring -- vec ) - [ spring-node-a node-pos ] [ spring-node-b node-pos ] bi v- ; + [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi v- ; : relative-velocity-along-spring-a ( spring -- vel ) [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ; @@ -126,10 +130,10 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-b ( spring -- vel ) - [ spring-node-b node-vel ] [ spring-node-a node-vel ] bi v- ; + [ spring-node-b vel>> ] [ spring-node-a vel>> ] bi v- ; : unit-vec-a->b ( spring -- vec ) - [ spring-node-b node-pos ] [ spring-node-a node-pos ] bi v- ; + [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi v- ; : relative-velocity-along-spring-b ( spring -- vel ) [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ; @@ -210,9 +214,9 @@ C: spring : calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ; : new-vel ( node -- vel ) - [ node-vel ] [ calc-acceleration time-slice> v*n ] bi v+ ; + [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ; -: new-pos ( node -- pos ) [ node-pos ] [ node-vel time-slice> v*n ] bi v+ ; +: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ; : iterate-node ( node -- ) dup new-pos >>pos @@ -231,16 +235,21 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : mass ( id x y x-vel y-vel mass elas -- ) - 7 nrot drop - 6 nrot 6 nrot 2array - 5 nrot 5 nrot 2array - 0 0 2array - nodes> swap suffix >nodes ; + node new + swap >>elas + swap >>mass + -rot 2array >>vel + -rot 2array >>pos + 0 0 2array >>force + nodes> swap suffix >nodes + drop ; : spng ( id id-a id-b k damp rest-length -- ) - 6 nrot drop - -rot - 5 nrot node-id - 5 nrot node-id - - springs> swap suffix >springs ; + spring new + swap >>rest-length + swap >>damp + swap >>k + swap node-id >>node-b + swap node-id >>node-a + springs> swap suffix >springs + drop ; \ No newline at end of file diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index 8aabe6b70b..365632e974 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -1,16 +1,16 @@ USING: kernel namespaces threads sequences math math.vectors opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate - fry rewrite-closures vars springies ; + fry rewrite-closures vars springies accessors math.geometry.rect ; IN: springies.ui ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: draw-node ( node -- ) node-pos { -5 -5 } v+ dup { 10 10 } v+ gl-rect ; +: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ; : draw-spring ( spring -- ) - [ spring-node-a node-pos ] [ spring-node-b node-pos ] bi gl-line ; + [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi gl-line ; : draw-nodes ( -- ) nodes> [ draw-node ] each ; From 610d38720ab1d9fa8ff9c565131e50ddb75299d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 20:05:32 -0500 Subject: [PATCH 11/73] Improve optimized-quot. --- extra/optimizer/debugger/debugger.factor | 30 ++++++++++++++---------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index e3740f9cba..c20685cf70 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -47,24 +47,28 @@ MATCH-VARS: ?a ?b ?c ; : pretty-shuffle ( in out -- word/f ) 2array { - { { { ?a } { } } drop } - { { { ?a ?b } { } } 2drop } - { { { ?a ?b ?c } { } } 3drop } - { { { ?a } { ?a ?a } } dup } - { { { ?a ?b } { ?a ?b ?a ?b } } 2dup } - { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup } - { { { ?a ?b } { ?a ?b ?a } } over } - { { { ?b ?a } { ?a ?b } } swap } - { { { ?a ?b ?c } { ?a ?b ?c ?a } } pick } - { { { ?a ?b ?c } { ?c ?a ?b } } -rot } - { { { ?a ?b ?c } { ?b ?c ?a } } rot } - { { { ?a ?b } { ?b } } nip } + { { { ?a } { ?a } } [ ] } + { { { ?a ?b } { ?a ?b } } [ ] } + { { { ?a ?b ?c } { ?a ?b ?c } } [ ] } + { { { ?a } { } } [ drop ] } + { { { ?a ?b } { } } [ 2drop ] } + { { { ?a ?b ?c } { } } [ 3drop ] } + { { { ?a } { ?a ?a } } [ dup ] } + { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] } + { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] } + { { { ?a ?b } { ?a ?b ?a } } [ over ] } + { { { ?b ?a } { ?a ?b } } [ swap ] } + { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } + { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } + { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } + { { { ?a ?b } { ?b } } [ nip ] } + { { { ?a ?b ?c } { ?c } } [ 2nip ] } { _ f } } match-choose ; M: #shuffle node>quot dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle - [ , ] [ >r drop t r> ] if* + [ % ] [ >r drop t r> ] if* dup effect-str "#shuffle: " prepend comment, ; : pushed-literals ( node -- seq ) From e890b7a4bc53cb417d8782de8f39a821f735e9eb Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 20:31:15 -0500 Subject: [PATCH 12/73] More math.geometry.rect updates --- extra/ui/cocoa/cocoa.factor | 2 +- extra/ui/windows/windows.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index bf28740ecc..0085376eaa 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds -ui.cocoa.views core-foundation threads ; +ui.cocoa.views core-foundation threads math.geometry.rect ; IN: ui.cocoa TUPLE: handle view window ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 231dd7f8a5..a210287439 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line shuffle opengl ui.render unicode.case ascii -math.bitfields locals symbols accessors ; +math.bitfields locals symbols accessors math.geometry.rect ; IN: ui.windows SINGLETON: windows-ui-backend From d278025a39fe01d6c6f4e3bb5991ca93d8a1cba0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 20:33:08 -0500 Subject: [PATCH 13/73] Fix kernel tests --- core/kernel/kernel-tests.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index c5bd0615a7..195e9becae 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -114,10 +114,6 @@ IN: kernel.tests [ total-failure-1 ] must-fail -: total-failure-2 [ ] (call) unimplemented ; - -[ total-failure-2 ] must-fail - ! From combinators.lib [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test From 466a3fecd16166834e5a2bd254a14772c3a592fe Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 20:47:07 -0500 Subject: [PATCH 14/73] ui.cocoa.views: math.geometry.rect --- extra/ui/cocoa/views/views.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 68db5954d5..3bacad20b4 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -core-foundation threads combinators ; +core-foundation threads combinators math.geometry.rect ; IN: ui.cocoa.views : send-mouse-moved ( view event -- ) From 7e24f26b4d5baf5db0084ea2716adac3e288ca5d Mon Sep 17 00:00:00 2001 From: "U-VICTORIA\\Administrator" Date: Fri, 11 Jul 2008 18:49:11 -0700 Subject: [PATCH 15/73] Add missing import to ui.windows --- extra/ui/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 231dd7f8a5..a210287439 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line shuffle opengl ui.render unicode.case ascii -math.bitfields locals symbols accessors ; +math.bitfields locals symbols accessors math.geometry.rect ; IN: ui.windows SINGLETON: windows-ui-backend From f3d63e34acb79bb5558735cbc16f56f104352d92 Mon Sep 17 00:00:00 2001 From: "U-VICTORIA\\Administrator" Date: Fri, 11 Jul 2008 18:50:26 -0700 Subject: [PATCH 16/73] Add LPGUID typedef to windows.ole32 --- extra/windows/ole32/ole32.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor index 7daba37063..0e74dcfca3 100755 --- a/extra/windows/ole32/ole32.factor +++ b/extra/windows/ole32/ole32.factor @@ -10,6 +10,7 @@ TYPEDEF: void* LPUNKNOWN TYPEDEF: wchar_t* LPOLESTR TYPEDEF: wchar_t* LPCOLESTR +TYPEDEF: REFGUID LPGUID TYPEDEF: REFGUID REFIID TYPEDEF: REFGUID REFCLSID From 8d311fbf76e991c96542ff94da988b3f49cc382e Mon Sep 17 00:00:00 2001 From: "U-VICTORIA\\Administrator" Date: Fri, 11 Jul 2008 18:51:25 -0700 Subject: [PATCH 17/73] Update bunny, spheres, demo-support to use delegation --- extra/bunny/bunny.factor | 20 +++++++------------ extra/opengl/demo-support/demo-support.factor | 14 ++++++------- extra/spheres/spheres.factor | 5 ++--- 3 files changed, 16 insertions(+), 23 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index b4cefbc5bd..06959c91c2 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -7,28 +7,23 @@ opengl.demo-support multiline ui.gestures bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model accessors destructors ; IN: bunny -TUPLE: bunny-gadget model geom draw-seq draw-n ; +TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; : ( -- bunny-gadget ) - 0.0 0.0 0.375 - maybe-download read-model { - set-delegate - (>>model) - } bunny-gadget construct ; + 0.0 0.0 0.375 bunny-gadget new-demo-gadget + maybe-download read-model >>model-triangles ; : bunny-gadget-draw ( gadget -- draw ) - { draw-n>> draw-seq>> } - get-slots nth ; + [ draw-n>> ] [ draw-seq>> ] bi nth ; : bunny-gadget-next-draw ( gadget -- ) - dup { draw-seq>> draw-n>> } - get-slots + dup [ draw-seq>> ] [ draw-n>> ] bi 1+ swap length mod >>draw-n relayout-1 ; M: bunny-gadget graft* ( gadget -- ) GL_DEPTH_TEST glEnable - dup model>> >>geom + dup model-triangles>> >>geom dup [ ] [ ] @@ -48,8 +43,7 @@ M: bunny-gadget draw-gadget* ( gadget -- ) dup demo-gadget-set-matrices GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - { geom>> bunny-gadget-draw } get-slots - draw-bunny + [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny ] if ; M: bunny-gadget pref-dim* ( gadget -- dim ) diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 5dcbd526f2..2bf2abae95 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -9,10 +9,10 @@ IN: opengl.demo-support SYMBOL: last-drag-loc -TUPLE: demo-gadget yaw pitch distance ; +TUPLE: demo-gadget < gadget yaw pitch distance ; -: ( yaw pitch distance -- gadget ) - demo-gadget construct-gadget +: new-demo-gadget ( yaw pitch distance class -- gadget ) + new-gadget swap >>distance swap >>pitch swap >>yaw ; @@ -31,19 +31,19 @@ M: demo-gadget distance-step ( gadget -- dz ) : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; : yaw-demo-gadget ( yaw gadget -- ) - [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ; + [ + ] with change-yaw relayout-1 ; : pitch-demo-gadget ( pitch gadget -- ) - [ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ; + [ + ] with change-pitch relayout-1 ; : zoom-demo-gadget ( distance gadget -- ) - [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ; + [ + ] with change-distance relayout-1 ; M: demo-gadget pref-dim* ( gadget -- dim ) drop { 640 480 } ; : -+ ( x -- -x x ) - dup neg swap ; + [ neg ] keep ; : demo-gadget-frustum ( gadget -- -x x -y y near far ) [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index dff7313eec..9607f6d201 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -99,14 +99,13 @@ main() } ; -TUPLE: spheres-gadget +TUPLE: spheres-gadget < demo-gadget plane-program solid-sphere-program texture-sphere-program reflection-framebuffer reflection-depthbuffer reflection-texture ; : ( -- gadget ) - 20.0 10.0 20.0 - { set-delegate } spheres-gadget construct ; + 20.0 10.0 20.0 spheres-gadget new-demo-gadget ; M: spheres-gadget near-plane ( gadget -- z ) drop 1.0 ; From e08a04a03d532bd0948ecf1dfb6e805be488d79a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 20:58:09 -0500 Subject: [PATCH 18/73] automata.ui: math.geometry.rect --- extra/automata/ui/ui.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 467db53366..cfec6597c2 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -15,7 +15,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.grids ui.gadgets.theme namespaces.lib assocs.lib vars - rewrite-closures automata ; + rewrite-closures automata math.geometry.rect ; IN: automata.ui From b668936d9fa63bbf12deb37a0b1e17999c60a979 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 21:06:31 -0500 Subject: [PATCH 19/73] more rect updates --- extra/color-picker/color-picker.factor | 2 +- extra/jamshred/jamshred.factor | 5 ++++- extra/maze/maze.factor | 2 +- extra/processing/processing.factor | 2 +- extra/springies/springies.factor | 2 ++ extra/tetris/tetris.factor | 3 ++- extra/ui/gadgets/frame-buffer/frame-buffer.factor | 2 +- 7 files changed, 12 insertions(+), 6 deletions(-) diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 99968ca3c3..6fcf3c21cd 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -3,7 +3,7 @@ USING: kernel math math.functions math.parser models models.filter models.range models.compose sequences ui ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs -ui.gadgets.sliders ui.render ; +ui.gadgets.sliders ui.render math.geometry.rect ; IN: color-picker ! Simple example demonstrating the use of models. diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index b7764894d1..d9a0f84b53 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl +jamshred.player jamshred.log kernel math math.constants namespaces +sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds +ui.gestures ui.render math.vectors math.geometry.rect ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index dbf983be62..389dabc0f6 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -1,7 +1,7 @@ ! From http://www.ffconsultancy.com/ocaml/maze/index.html USING: sequences namespaces math math.vectors opengl opengl.gl arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render -math.order ; +math.order math.geometry.rect ; IN: maze : line-width 8 ; diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index fb9f321f47..4c9dd787e5 100755 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -10,7 +10,7 @@ USING: kernel namespaces threads combinators sequences arrays combinators.cleave rewrite-closures fry accessors newfx processing.color - processing.gadget ; + processing.gadget math.geometry.rect ; IN: processing diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index 2640423eb4..fb69783975 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -38,6 +38,8 @@ C: node ! : >>vel ( node vel -- node ) over set-node-vel ; +: node-vel ( node -- vel ) vel>> ; + : set-node-vel ( vel node -- ) swap >>vel drop ; : pos-x ( node -- x ) pos>> first ; diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index c2f874598c..d01cec3790 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui -tetris.game tetris.gl sequences system math math.parser namespaces ; +tetris.game tetris.gl sequences system math math.parser namespaces +math.geometry.rect ; IN: tetris TUPLE: tetris-gadget tetris alarm ; diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor index a288f74f64..7d77db24cc 100644 --- a/extra/ui/gadgets/frame-buffer/frame-buffer.factor +++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor @@ -1,7 +1,7 @@ USING: kernel alien.c-types combinators sequences splitting grouping opengl.gl ui.gadgets ui.render - math math.vectors accessors ; + math math.vectors accessors math.geometry.rect ; IN: ui.gadgets.frame-buffer From b19c3ee65e7655fbb9ce71692751bfe31a4e8ada Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 11 Jul 2008 19:34:42 -0700 Subject: [PATCH 20/73] use single-precision floats in bunny vertex buffers for much better performance --- extra/bunny/model/model.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index fce73785b5..6723f94353 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii opengl.capabilities shuffle http.client vectors splitting system combinators -float-arrays continuations destructors namespaces sequences.lib +continuations destructors namespaces sequences.lib accessors ; IN: bunny.model @@ -66,7 +66,7 @@ TUPLE: bunny-buffers array element-array nv ni ; { [ [ first concat ] [ second concat ] bi - append >c-double-array + append >c-float-array GL_ARRAY_BUFFER swap GL_STATIC_DRAW ] [ @@ -86,10 +86,10 @@ M: bunny-dlist bunny-geom M: bunny-buffers bunny-geom dup { array>> element-array>> } get-slots [ { GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [ - GL_DOUBLE 0 0 buffer-offset glNormalPointer + GL_FLOAT 0 0 buffer-offset glNormalPointer [ - nv>> "double" heap-size * buffer-offset - 3 GL_DOUBLE 0 roll glVertexPointer + nv>> "float" heap-size * buffer-offset + 3 GL_FLOAT 0 roll glVertexPointer ] [ ni>> GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements From 5b0fbf9abf092fac48da24353ba1632c6e703adc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 11 Jul 2008 19:48:41 -0700 Subject: [PATCH 21/73] Whip the out-of-control USING: lines in bunny into shape --- extra/bunny/bunny.factor | 10 +++------- extra/bunny/model/model.factor | 10 ++++------ 2 files changed, 7 insertions(+), 13 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 06959c91c2..ed89f2a809 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,10 +1,6 @@ -USING: alien alien.c-types arrays sequences math math.vectors -math.matrices math.parser io io.files kernel opengl opengl.gl -opengl.glu shuffle http.client vectors namespaces ui.gadgets -ui.gadgets.canvas ui.render ui splitting combinators -system combinators.lib float-arrays continuations -opengl.demo-support multiline ui.gestures bunny.fixed-pipeline -bunny.cel-shaded bunny.outlined bunny.model accessors destructors ; +USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline +bunny.model bunny.outlined destructors kernel math opengl.demo-support +opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ; IN: bunny TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 6723f94353..f64030ff70 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,9 +1,7 @@ -USING: alien alien.c-types arrays sequences math math.vectors -math.matrices math.parser io io.files kernel opengl opengl.gl -opengl.glu io.encodings.ascii opengl.capabilities shuffle -http.client vectors splitting system combinators -continuations destructors namespaces sequences.lib -accessors ; +USING: accessors alien.c-types arrays combinators destructors http.client +io io.encodings.ascii io.files kernel math math.matrices math.parser +math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib +splitting vectors words ; IN: bunny.model : numbers ( str -- seq ) From 7608afbf4c445f1a6da613019fa9a67e86473c1a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 11 Jul 2008 20:16:22 -0700 Subject: [PATCH 22/73] duh... bunny.outlined needs to update the framebuffer size after it builds it! --- extra/bunny/outlined/outlined.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index f3ee4594c7..fcba98a0e9 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -181,10 +181,9 @@ TUPLE: bunny-outlined ] [ drop ] if ; : remake-framebuffer-if-needed ( draw -- ) - dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi - over = - [ 2drop ] [ - [ dup dispose-framebuffer dup ] dip { + dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi = + [ drop ] [ + [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri { [ GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) [ >>color-texture drop ] keep @@ -196,7 +195,8 @@ TUPLE: bunny-outlined [ >>depth-texture drop ] keep ] } 2cleave - (make-framebuffer) >>framebuffer drop + [ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi + drop ] if ; : clear-framebuffer ( -- ) From 9232f16732d354cc502a218bb40b29644f418727 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 23:54:53 -0500 Subject: [PATCH 23/73] math.geometry.rect.tests --- extra/math/geometry/rect/rect-tests.factor | 37 ++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 extra/math/geometry/rect/rect-tests.factor diff --git a/extra/math/geometry/rect/rect-tests.factor b/extra/math/geometry/rect/rect-tests.factor new file mode 100644 index 0000000000..0d2a8bc1ea --- /dev/null +++ b/extra/math/geometry/rect/rect-tests.factor @@ -0,0 +1,37 @@ + +USING: tools.test math.geometry.rect ; + +IN: math.geometry.rect.tests + +[ T{ rect f { 10 10 } { 20 20 } } ] +[ + T{ rect f { 10 10 } { 50 50 } } + T{ rect f { -10 -10 } { 40 40 } } + rect-intersect +] unit-test + +[ T{ rect f { 200 200 } { 0 0 } } ] +[ + T{ rect f { 100 100 } { 50 50 } } + T{ rect f { 200 200 } { 40 40 } } + rect-intersect +] unit-test + +[ f ] [ + T{ rect f { 100 100 } { 50 50 } } + T{ rect f { 200 200 } { 40 40 } } + intersects? +] unit-test + +[ t ] [ + T{ rect f { 100 100 } { 50 50 } } + T{ rect f { 120 120 } { 40 40 } } + intersects? +] unit-test + +[ f ] [ + T{ rect f { 1000 100 } { 50 50 } } + T{ rect f { 120 120 } { 40 40 } } + intersects? +] unit-test + From 9043ad0e4a70b53b2874d346598a307eea7c46a0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 23:57:27 -0500 Subject: [PATCH 24/73] update tests for math.geometry.rect --- extra/ui/gadgets/borders/borders-tests.factor | 2 +- extra/ui/gadgets/gadgets-tests.factor | 34 +------------------ extra/ui/gadgets/grids/grids-tests.factor | 2 +- extra/ui/gadgets/packs/packs-tests.factor | 2 +- .../gadgets/scrollers/scrollers-tests.factor | 2 +- extra/ui/gadgets/tracks/tracks-tests.factor | 2 +- 6 files changed, 6 insertions(+), 38 deletions(-) diff --git a/extra/ui/gadgets/borders/borders-tests.factor b/extra/ui/gadgets/borders/borders-tests.factor index 268d1ab0a3..0151996c02 100644 --- a/extra/ui/gadgets/borders/borders-tests.factor +++ b/extra/ui/gadgets/borders/borders-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.borders.tests USING: tools.test accessors namespaces kernel -ui.gadgets ui.gadgets.borders ; +ui.gadgets ui.gadgets.borders math.geometry.rect ; [ { 110 210 } ] [ { 100 200 } >>dim 5 pref-dim ] unit-test diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index dbb2919277..1bea304f15 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -2,39 +2,7 @@ IN: ui.gadgets.tests USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel dlists dequeues math sets math.parser ui sequences hashtables assocs io arrays prettyprint -io.streams.string ; - -[ T{ rect f { 10 10 } { 20 20 } } ] -[ - T{ rect f { 10 10 } { 50 50 } } - T{ rect f { -10 -10 } { 40 40 } } - rect-intersect -] unit-test - -[ T{ rect f { 200 200 } { 0 0 } } ] -[ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 200 200 } { 40 40 } } - rect-intersect -] unit-test - -[ f ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 200 200 } { 40 40 } } - intersects? -] unit-test - -[ t ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 120 120 } { 40 40 } } - intersects? -] unit-test - -[ f ] [ - T{ rect f { 1000 100 } { 50 50 } } - T{ rect f { 120 120 } { 40 40 } } - intersects? -] unit-test +io.streams.string math.geometry.rect ; [ { 300 300 } ] [ diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/extra/ui/gadgets/grids/grids-tests.factor index f20275ff25..cfca5d5a93 100644 --- a/extra/ui/gadgets/grids/grids-tests.factor +++ b/extra/ui/gadgets/grids/grids-tests.factor @@ -1,5 +1,5 @@ USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays -namespaces ; +namespaces math.geometry.rect ; IN: ui.gadgets.grids.tests [ { 0 0 } ] [ { } pref-dim ] unit-test diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/extra/ui/gadgets/packs/packs-tests.factor index 28a656e2ad..4ae84f83df 100644 --- a/extra/ui/gadgets/packs/packs-tests.factor +++ b/extra/ui/gadgets/packs/packs-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.packs.tests USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render -kernel namespaces tools.test math.parser sequences ; +kernel namespaces tools.test math.parser sequences math.geometry.rect ; [ t ] [ { 0 0 } { 100 100 } clip set diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index 4df92141ba..cfbb1fdca5 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -3,7 +3,7 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models models.compose models.range ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames ui.gadgets.sliders math math.vectors arrays sequences -tools.test.ui ; +tools.test.ui math.geometry.rect ; [ ] [ "g" set diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/extra/ui/gadgets/tracks/tracks-tests.factor index e2db914089..d3264b2470 100644 --- a/extra/ui/gadgets/tracks/tracks-tests.factor +++ b/extra/ui/gadgets/tracks/tracks-tests.factor @@ -1,4 +1,4 @@ -USING: kernel ui.gadgets ui.gadgets.tracks tools.test ; +USING: kernel ui.gadgets ui.gadgets.tracks tools.test math.geometry.rect ; IN: ui.gadgets.tracks.tests [ { 100 100 } ] [ From 4812c95db68a2097e7aba4174ee1bbc48f0de100 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 00:49:02 -0500 Subject: [PATCH 25/73] automata: use --- extra/automata/automata.factor | 21 ++++----------------- 1 file changed, 4 insertions(+), 17 deletions(-) diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index b6d4152d0e..a70eaa063d 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser random arrays hashtables assocs sequences - vars ; + grouping vars ; IN: automata @@ -32,29 +32,16 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; ! step-wrapped-line ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 3nth ( n seq -- slice ) >r dup 3 + r> ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: map3-i ( seq -- i ) length 2 - ; - -: map3-quot ( seq quot -- quot ) >r [ 3nth ] curry r> compose ; inline - -: map3 ( seq quot -- seq ) >r dup map3-i swap r> map3-quot map ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: pattern>state ( {_a_b_c_} -- state ) rule> at ; +: pattern>state ( {_a_b_c_} -- state ) >array rule> at ; : cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ; : wrap-line ( a-line-z -- za-line-za ) dup peek 1array swap dup first 1array append append ; -: step-line ( line -- new-line ) [ >array pattern>state ] map3 ; - -: step-capped-line ( line -- new-line ) cap-line step-line ; +: step-line ( line -- new-line ) 3 [ pattern>state ] map ; +: step-capped-line ( line -- new-line ) cap-line step-line ; : step-wrapped-line ( line -- new-line ) wrap-line step-line ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 7ca3c2a878a8772c228f14888ef1259bf6e25bd4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 01:08:30 -0500 Subject: [PATCH 26/73] Various minor compiler tweaks --- core/alien/c-types/c-types-tests.factor | 2 + core/alien/c-types/c-types.factor | 6 +- core/classes/algebra/algebra-tests.factor | 6 ++ core/classes/singleton/singleton.factor | 6 +- core/classes/tuple/tuple.factor | 2 + core/growable/growable.factor | 7 ++ core/inference/class/class-tests.factor | 38 ++++++-- core/inference/class/class.factor | 19 +++- core/inference/known-words/known-words.factor | 6 +- core/io/encodings/encodings.factor | 21 +++-- core/io/encodings/utf8/utf8.factor | 14 +-- core/optimizer/inlining/inlining-tests.factor | 11 --- core/optimizer/inlining/inlining.factor | 89 +++++++++++++------ core/optimizer/math/math.factor | 67 ++++++++++++-- core/optimizer/math/partial/partial.factor | 3 + core/optimizer/optimizer-tests.factor | 9 ++ core/sequences/sequences.factor | 7 +- core/slots/slots.factor | 6 +- extra/benchmark/stack/stack.factor | 19 ++++ extra/float-arrays/float-arrays.factor | 17 ++++ extra/hints/hints.factor | 10 ++- extra/io/buffers/buffers.factor | 2 +- extra/io/ports/ports.factor | 18 ++-- extra/tools/deploy/shaker/shaker.factor | 1 + 24 files changed, 296 insertions(+), 90 deletions(-) create mode 100644 extra/benchmark/stack/stack.factor diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 5f57068bab..276dd581c5 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -48,3 +48,5 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } ] must-fail + +[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 602b22881f..e576b87f52 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -348,7 +348,7 @@ M: long-long-type box-return ( type -- ) [ alien-unsigned-4 zero? not ] >>getter - [ 1 0 ? set-alien-unsigned-4 ] >>setter + [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter 4 >>size 4 >>align "box_boolean" >>boxer @@ -357,7 +357,7 @@ M: long-long-type box-return ( type -- ) [ alien-float ] >>getter - [ >r >r >float r> r> set-alien-float ] >>setter + [ [ >float ] 2dip set-alien-float ] >>setter 4 >>size 4 >>align "box_float" >>boxer @@ -368,7 +368,7 @@ M: long-long-type box-return ( type -- ) [ alien-double ] >>getter - [ >r >r >float r> r> set-alien-double ] >>setter + [ [ >float ] 2dip set-alien-double ] >>setter 8 >>size 8 >>align "box_double" >>boxer diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 444cf50e58..665fc86ebb 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -306,3 +306,9 @@ INTERSECTION: empty-intersection ; [ t ] [ object \ f class-not \ f class-or class<= ] unit-test [ ] [ object flatten-builtin-class drop ] unit-test + +SINGLETON: sa +SINGLETON: sb +SINGLETON: sc + +[ sa ] [ sa { sa sb sc } min-class ] unit-test diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index a72c9f1333..1d370c1859 100755 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.predicate kernel sequences words ; +USING: classes classes.algebra classes.predicate kernel +sequences words ; IN: classes.singleton PREDICATE: singleton-class < predicate-class @@ -11,3 +12,6 @@ PREDICATE: singleton-class < predicate-class \ word over [ eq? ] curry define-predicate-class ; M: singleton-class instance? eq? ; + +M: singleton-class (classes-intersect?) + over singleton-class? [ eq? ] [ call-next-method ] if ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 6cf6a9897a..71c5f3efe6 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -336,6 +336,8 @@ M: tuple-class boa [ tuple-layout ] bi ; +M: tuple-class initial-value* new ; + ! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 57919671c8..336f1da91a 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -59,4 +59,11 @@ M: growable lengthen ( n seq -- ) 2dup (>>length) ] when 2drop ; +M: growable shorten ( n seq -- ) + growable-check + 2dup length < [ + 2dup contract + 2dup (>>length) + ] when 2drop ; + INSTANCE: growable sequence diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 591baf1287..7be70f1ad4 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -5,8 +5,9 @@ sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units system layouts vectors optimizer.math.partial -optimizer.inlining optimizer.backend math.order -accessors hashtables classes assocs ; +optimizer.inlining optimizer.backend math.order math.functions +accessors hashtables classes assocs io.encodings.utf8 +io.encodings.ascii io.encodings ; [ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test @@ -193,19 +194,15 @@ M: fixnum detect-fx ; [ t ] [ - [ { string sbuf } declare push-all ] \ push-all inlined? + [ { string sbuf } declare ] \ push-all def>> append \ + inlined? ] unit-test [ t ] [ - [ { string sbuf } declare push-all ] \ + inlined? + [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined? ] unit-test [ t ] [ - [ { string sbuf } declare push-all ] \ fixnum+ inlined? -] unit-test - -[ t ] [ - [ { string sbuf } declare push-all ] \ >fixnum inlined? + [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? ] unit-test [ t ] [ @@ -600,6 +597,29 @@ TUPLE: declared-fixnum { x fixnum } ; { slot } inlined? ] unit-test +[ t ] [ + [ + { array } declare length + 1 + dup 100 fixnum> [ 1 fixnum+ ] when + ] \ fixnum+ inlined? +] unit-test + +[ t ] [ + [ [ resize-array ] keep length ] \ length inlined? +] unit-test + +[ t ] [ + [ dup 0 > [ sqrt ] when ] \ sqrt inlined? +] unit-test + +[ t ] [ + [ { utf8 } declare decode-char ] \ decode-char inlined? +] unit-test + +[ t ] [ + [ { ascii } declare decode-char ] \ decode-char inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 2f7058ba96..7cd0c1d540 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -129,8 +129,12 @@ GENERIC: infer-classes-before ( node -- ) GENERIC: infer-classes-around ( node -- ) +GENERIC: infer-classes-after ( node -- ) + M: node infer-classes-before drop ; +M: node infer-classes-after drop ; + M: node child-constraints children>> length dup zero? [ drop f ] [ f ] if ; @@ -203,11 +207,19 @@ M: pair constraint-satisfied? [ ] [ param>> "default-output-classes" word-prop ] ?if r> ; -M: #call infer-classes-before - [ compute-constraints ] keep - [ output-classes ] [ out-d>> ] bi +: intersect-values ( classes intervals values -- ) tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ; +M: #call infer-classes-before + [ compute-constraints ] + [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ; + +: input-classes ( #call -- classes ) + param>> "input-classes" word-prop ; + +M: #call infer-classes-after + [ input-classes ] [ in-d>> ] bi intersect-classes ; + M: #push infer-classes-before out-d>> [ [ value-literal ] keep set-value-literal* ] each ; @@ -340,6 +352,7 @@ M: object infer-classes-around { [ infer-classes-before ] [ annotate-node ] + [ infer-classes-after ] [ infer-children ] [ merge-children ] } cleave ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 6f5277bc35..1c9138fe0b 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -153,8 +153,10 @@ M: object infer-call ] "infer" set-word-prop : set-primitive-effect ( word effect -- ) - 2dup effect-out "default-output-classes" set-word-prop - dupd [ make-call-node ] 2curry "infer" set-word-prop ; + [ in>> "input-classes" set-word-prop ] + [ out>> "default-output-classes" set-word-prop ] + [ dupd [ make-call-node ] 2curry "infer" set-word-prop ] + 2tri ; ! Stack effects for all primitives \ fixnum< { fixnum fixnum } { object } set-primitive-effect diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 942476616f..0181f80af4 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -99,14 +99,20 @@ M: decoder stream-read-partial stream-read ; [ >r drop "" like r> ] [ pick push ((read-until)) ] if ; inline -: (read-until) ( seps stream -- string/f sep/f ) - SBUF" " clone -rot >decoder< +: (read-until) ( quot -- string/f sep/f ) + 100 swap ((read-until)) ; inline + +: decoder-read-until ( seps stream encoding -- string/f sep/f ) [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry - ((read-until)) ; inline + (read-until) ; -M: decoder stream-read-until (read-until) ; +M: decoder stream-read-until >decoder< decoder-read-until ; -M: decoder stream-readln "\r\n" over (read-until) handle-readln ; +: decoder-readln ( stream encoding -- string/f sep/f ) + [ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry + (read-until) ; + +M: decoder stream-readln dup >decoder< decoder-readln handle-readln ; M: decoder dispose stream>> dispose ; @@ -119,8 +125,11 @@ M: object encoder boa ; M: encoder stream-write1 >encoder< encode-char ; +: decoder-write ( string stream encoding -- ) + [ encode-char ] 2curry each ; + M: encoder stream-write - >encoder< [ encode-char ] 2curry each ; + >encoder< decoder-write ; M: encoder dispose encoder-stream dispose ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 09524802e0..ae8a455c71 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -11,21 +11,21 @@ SINGLETON: utf8 >length) method should-inline? ] unit-test diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 618a2c746d..30acdb1b48 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel -math namespaces sequences vectors words quotations hashtables -combinators classes classes.algebra generic.math -optimizer.math.partial continuations optimizer.def-use -optimizer.backend generic.standard optimizer.specializers -optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private definitions sets ; +math math.order namespaces sequences vectors words quotations +hashtables combinators effects classes classes.union +classes.algebra generic.math optimizer.math.partial +continuations optimizer.def-use optimizer.backend +generic.standard optimizer.specializers optimizer.def-use +optimizer.pattern-match generic.standard optimizer.control +kernel.private definitions sets summary ; IN: optimizer.inlining : remember-inlining ( node history -- ) @@ -31,9 +32,9 @@ DEFER: (flat-length) : word-flat-length ( word -- n ) { ! not inline - { [ dup inline? not ] [ drop 0 ] } + { [ dup inline? not ] [ drop 1 ] } ! recursive and inline - { [ dup recursive-calls get key? ] [ drop 4 ] } + { [ dup recursive-calls get key? ] [ drop 10 ] } ! inline [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ] } cond ; @@ -41,7 +42,7 @@ DEFER: (flat-length) : (flat-length) ( seq -- n ) [ { - { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup quotation? ] [ (flat-length) 2 + ] } { [ dup array? ] [ (flat-length) ] } { [ dup word? ] [ word-flat-length ] } [ drop 0 ] @@ -51,7 +52,7 @@ DEFER: (flat-length) : flat-length ( word -- n ) H{ } clone recursive-calls [ [ recursive-calls get conjoin ] - [ def>> (flat-length) ] + [ def>> (flat-length) 5 /i ] bi ] with-variable ; @@ -102,7 +103,7 @@ DEFER: (flat-length) [ f splice-quot ] [ 2drop t ] if ; : inline-method ( #call -- node ) - dup node-param { + dup param>> { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } { [ dup math-partial? ] [ inline-math-partial ] } @@ -155,15 +156,35 @@ DEFER: (flat-length) (optimize-predicate) optimize-check ; : flush-eval? ( #call -- ? ) - dup node-param "flushable" word-prop [ - node-out-d [ unused? ] all? - ] [ - drop f - ] if ; + dup node-param "flushable" word-prop + [ node-out-d [ unused? ] all? ] [ drop f ] if ; + +ERROR: flushed-eval-error word ; + +M: flushed-eval-error summary + drop "Flushed evaluation of word would have thrown an error" ; + +: flushed-eval-quot ( #call -- quot ) + #! A quotation to replace flushed evaluations with. We can't + #! just remove the code altogether, because if the optimizer + #! knows the input types of a word, it assumes the inputs are + #! of this type after the word returns, since presumably + #! the word would have checked input types itself. However, + #! if the word gets flushed, then it won't do this checking; + #! so we have to do it here. + [ + dup param>> "input-classes" word-prop [ + make-specializer % + [ dup param>> literalize , \ flushed-eval-error , ] [ ] make , + \ unless , + ] when* + dup in-d>> length [ \ drop , ] times + out-d>> length [ f , ] times + ] [ ] make ; : flush-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup node-out-d length f inline-literals ; + dup param>> +inlined+ depends-on + dup flushed-eval-quot f splice-quot ; : partial-eval? ( #call -- ? ) dup node-param "foldable" word-prop [ @@ -195,13 +216,28 @@ DEFER: (flat-length) [ drop +inlined+ depends-on ] [ swap 1array ] 2bi splice-quot ; +: classes-known? ( #call -- ? ) + node-input-classes [ + [ class-types length 1 = ] + [ union-class? not ] + bi and + ] contains? ; + +: inlining-rank ( #call -- n ) + { + [ param>> flat-length 24 swap [-] 4 /i ] + [ param>> "default" word-prop -4 0 ? ] + [ param>> "specializer" word-prop 1 0 ? ] + [ param>> method-body? 1 0 ? ] + [ classes-known? 2 0 ? ] + } cleave + + + + ; + +: should-inline? ( #call -- ? ) + inlining-rank 5 >= ; + : optimistic-inline? ( #call -- ? ) - dup node-param "specializer" word-prop dup [ - >r node-input-classes r> specialized-length tail* - [ class-types length 1 = ] all? - ] [ - 2drop f - ] if ; + dup param>> "specializer" word-prop + [ should-inline? ] [ drop f ] if ; : already-inlined? ( #call -- ? ) [ param>> ] [ history>> ] bi memq? ; @@ -211,11 +247,8 @@ DEFER: (flat-length) dup param>> dup def>> splice-word-def ] if ; -: should-inline? ( word -- ? ) - flat-length 11 <= ; - : method-body-inline? ( #call -- ? ) - param>> dup [ method-body? ] [ "default" word-prop not ] bi and + dup param>> method-body? [ should-inline? ] [ drop f ] if ; M: #call optimize-node* diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 27ef4042e2..799f4d80cf 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: effects alien alien.accessors arrays generic hashtables +kernel assocs math math.libm math.private kernel.private +sequences words parser inference.class inference.dataflow +vectors strings sbufs io namespaces assocs quotations +math.intervals sequences.private combinators splitting layouts +math.parser classes classes.algebra generic.math +optimizer.pattern-match optimizer.backend optimizer.def-use +optimizer.inlining optimizer.math.partial generic.standard +system accessors ; IN: optimizer.math -USING: alien alien.accessors arrays generic hashtables kernel -assocs math math.private kernel.private sequences words parser -inference.class inference.dataflow vectors strings sbufs io -namespaces assocs quotations math.intervals sequences.private -combinators splitting layouts math.parser classes -classes.algebra generic.math optimizer.pattern-match -optimizer.backend optimizer.def-use optimizer.inlining -optimizer.math.partial generic.standard system accessors ; : define-math-identities ( word identities -- ) >r all-derived-ops r> define-identities ; @@ -169,6 +170,22 @@ optimizer.math.partial generic.standard system accessors ; ] 2curry each-derived-op ] each +: math-output-class/interval-2-fast ( node word -- classes intervals ) + math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline + +[ + { + interval+ } + { - interval- } + { * interval* } + { shift interval-shift-safe } +] [ + first2 [ + [ + math-output-class/interval-2-fast + ] curry "output-classes" set-word-prop + ] curry each-fast-derived-op +] each + : real-value? ( value -- n ? ) dup value? [ value-literal dup real? ] [ drop f f ] if ; @@ -420,3 +437,37 @@ most-negative-fixnum most-positive-fixnum [a,b] [ fixnumify-bitand ] } } define-optimizers + +{ + - * / } +[ { number number } "input-classes" set-word-prop ] each + +{ /f < > <= >= } +[ { real real } "input-classes" set-word-prop ] each + +{ /i bitand bitor bitxor bitnot shift } +[ { integer integer } "input-classes" set-word-prop ] each + +{ + fcosh + flog + fsinh + fexp + fasin + facosh + fasinh + ftanh + fatanh + facos + fpow + fatan + fatan2 + fcos + ftan + fsin + fsqrt +} [ + dup stack-effect + [ in>> length real "input-classes" set-word-prop ] + [ out>> length float "default-output-classes" set-word-prop ] + 2bi +] each diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor index 4f9bfaef12..ad9feeed4a 100644 --- a/core/optimizer/math/partial/partial.factor +++ b/core/optimizer/math/partial/partial.factor @@ -170,3 +170,6 @@ SYMBOL: fast-math-ops : each-derived-op ( word quot -- ) >r derived-ops r> each ; inline + +: each-fast-derived-op ( word quot -- ) + >r fast-derived-ops r> each ; inline diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 655b54ea96..0a3439c65c 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -375,3 +375,12 @@ PREDICATE: list < improper-list [ 2 3 ] [ 2 interval-inference-bug ] unit-test [ 1 4 ] [ 1 interval-inference-bug ] unit-test [ 0 5 ] [ 0 interval-inference-bug ] unit-test + +: aggressive-flush-regression ( a -- b ) + f over >r drop r> 1 + ; + +[ 1.0 aggressive-flush-regression drop ] must-fail + +[ 1 [ "hi" + drop ] compile-call ] must-fail + +[ "hi" f [ drop ] compile-call ] must-fail diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index bc92055338..c433ce4426 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -21,9 +21,12 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable M: sequence like drop ; GENERIC: lengthen ( n seq -- ) +GENERIC: shorten ( n seq -- ) M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; +M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; + : empty? ( seq -- ? ) length zero? ; inline : delete-all ( seq -- ) 0 swap set-length ; @@ -530,7 +533,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : peek ( seq -- elt ) [ length 1- ] [ nth ] bi ; -: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ; +: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ; : move-backward ( shift from to seq -- ) 2over number= [ @@ -575,7 +578,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; copy ; : pop ( seq -- elt ) - [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ; + [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; : all-equal? ( seq -- ? ) [ = ] monotonic? ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 1453393a27..a5b2e4b3d8 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -125,6 +125,10 @@ ERROR: bad-slot-value value class ; ERROR: no-initial-value class ; +GENERIC: initial-value* ( class -- object ) + +M: class initial-value* no-initial-value ; + : initial-value ( class -- object ) { { [ \ f bootstrap-word over class<= ] [ f ] } @@ -134,7 +138,7 @@ ERROR: no-initial-value class ; { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ simple-alien bootstrap-word over class<= ] [ ] } - [ no-initial-value ] + [ dup initial-value* ] } cond nip ; GENERIC: make-slot ( desc -- slot-spec ) diff --git a/extra/benchmark/stack/stack.factor b/extra/benchmark/stack/stack.factor new file mode 100644 index 0000000000..d4dc18e80f --- /dev/null +++ b/extra/benchmark/stack/stack.factor @@ -0,0 +1,19 @@ +USING: kernel sequences math math.functions vectors ; +IN: benchmark.stack + +: stack-loop ( vec -- ) + 1000 [ + 10000 [ + dup pop dup ! dup 10 > [ sqrt dup 1 + ] [ dup 2 * ] if + pick push + over push + ] times + 10000 [ dup pop* ] times + ] times + drop ; + +: stack-benchmark ( -- ) + V{ 123456 } clone stack-loop + 20000 123456 over set-first stack-loop ; + +MAIN: stack-benchmark diff --git a/extra/float-arrays/float-arrays.factor b/extra/float-arrays/float-arrays.factor index 025a580633..668bb7de41 100755 --- a/extra/float-arrays/float-arrays.factor +++ b/extra/float-arrays/float-arrays.factor @@ -72,3 +72,20 @@ INSTANCE: float-array sequence M: float-array pprint-delims drop \ F{ \ } ; M: float-array >pprint-sequence ; + +USING: hints math.vectors arrays ; + +HINTS: vneg { float-array } { array } ; +HINTS: v*n { float-array object } { array object } ; +HINTS: v/n { float-array object } { array object } ; +HINTS: n/v { object float-array } { object array } ; +HINTS: v+ { float-array float-array } { array array } ; +HINTS: v- { float-array float-array } { array array } ; +HINTS: v* { float-array float-array } { array array } ; +HINTS: v/ { float-array float-array } { array array } ; +HINTS: vmax { float-array float-array } { array array } ; +HINTS: vmin { float-array float-array } { array array } ; +HINTS: v. { float-array float-array } { array array } ; +HINTS: norm-sq { float-array } { array } ; +HINTS: norm { float-array } { array } ; +HINTS: normalize { float-array } { array } ; diff --git a/extra/hints/hints.factor b/extra/hints/hints.factor index 266e635867..82941a69de 100644 --- a/extra/hints/hints.factor +++ b/extra/hints/hints.factor @@ -1,6 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser words definitions kernel ; IN: hints -USING: parser words ; -: HINTS: - scan-word parse-definition "specializer" set-word-prop ; +: HINTS: + scan-word + [ +inlined+ changed-definition ] + [ parse-definition "specializer" set-word-prop ] bi ; parsing diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index f08082c4ee..e6a0070ee0 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -25,7 +25,7 @@ M: buffer dispose* ptr>> free ; [ size>> ] [ fill>> ] bi - ; inline : buffer-empty? ( buffer -- ? ) - fill>> zero? ; + fill>> zero? ; inline : buffer-consume ( n buffer -- ) [ + ] change-pos diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 77e984e6e5..26b06dba8b 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -19,7 +19,7 @@ M: port set-timeout (>>timeout) ; : ( handle class -- port ) new swap >>handle ; inline -TUPLE: buffered-port < port buffer ; +TUPLE: buffered-port < port { buffer buffer } ; : ( handle class -- port ) @@ -35,7 +35,7 @@ HOOK: (wait-to-read) io-backend ( port -- ) : wait-to-read ( port -- eof? ) dup buffer>> buffer-empty? [ dup (wait-to-read) buffer>> buffer-empty? - ] [ drop f ] if ; + ] [ drop f ] if ; inline M: input-port stream-read1 dup check-disposed @@ -140,9 +140,7 @@ M: output-port dispose* ] with-destructors ; M: buffered-port dispose* - [ call-next-method ] - [ [ [ dispose ] when* f ] change-buffer drop ] - bi ; + [ call-next-method ] [ buffer>> dispose ] bi ; M: port cancel-operation handle>> cancel-operation ; @@ -152,3 +150,13 @@ M: port dispose* [ handle>> shutdown ] bi ] with-destructors ; + +! Fast-path optimization +USING: hints strings io.encodings.utf8 io.encodings.ascii +io.encodings.private ; + +HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ; + +HINTS: decoder-readln { input-port utf8 } { input-port ascii } ; + +HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 2dd334d024..0e20384839 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -101,6 +101,7 @@ IN: tools.deploy.shaker "if-intrinsics" "infer" "inferred-effect" + "input-classes" "interval" "intrinsics" "loc" From 1253aed5cd4ebc6d29d651fc79dab8037eba6c1f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 01:24:10 -0500 Subject: [PATCH 27/73] Doc update --- core/slots/slots-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 39a501c7f8..acca168a4c 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -77,6 +77,7 @@ $nl "All other classes are handled with one of two cases:" { $list { "If the class is a union or mixin class which " { $emphasis "contains" } " one of the above known classes, then the initial value of the class is that of the known class, with preference given to classes earlier in the list. For example, if the slot is declared " { $link object } " (this is the default), the initial value is " { $link f } ". Similarly for " { $link sequence } " and " { $link assoc } "." } + { "If the class is a tuple class, the initial value of the slot is a new, shared instance of the class created with " { $link new } "." } { "Otherwise, a " { $link no-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." } } "A word can be used to check if a class has an initial value or not:" From 41adbaf6bec27b5339a34fcddb35ec7c7ed86023 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 01:29:12 -0500 Subject: [PATCH 28/73] Fix display regression --- extra/ui/gadgets/borders/borders.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 2c232392ce..7d6a24fed1 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -33,7 +33,8 @@ M: border pref-dim* [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ; : border-loc ( border dim -- loc ) - [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ; + [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip + v- v* v+ [ >fixnum ] map ; : border-child-rect ( border -- rect ) dup border-dim [ border-loc ] keep ; From 3e082f21e37c0ff5f83a1d05e99110fa61d32e32 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 01:29:25 -0500 Subject: [PATCH 29/73] Update minor demos for inheritance --- extra/gesture-logger/gesture-logger.factor | 4 ++-- extra/nehe/2/2.factor | 4 ++-- extra/nehe/3/3.factor | 4 ++-- extra/nehe/4/4.factor | 4 ++-- extra/nehe/5/5.factor | 4 ++-- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index ba0ff5bedd..d79593c337 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -5,10 +5,10 @@ ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors accessors ; IN: gesture-logger -TUPLE: gesture-logger stream ; +TUPLE: gesture-logger < gadget stream ; : ( stream -- gadget ) - \ gesture-logger construct-gadget + \ gesture-logger new-gadget swap >>stream { 100 100 } >>dim black solid-interior ; diff --git a/extra/nehe/2/2.factor b/extra/nehe/2/2.factor index 1084a3303e..d9560c92f6 100644 --- a/extra/nehe/2/2.factor +++ b/extra/nehe/2/2.factor @@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui ui.gadgets ui.render ; IN: nehe.2 -TUPLE: nehe2-gadget ; +TUPLE: nehe2-gadget < gadget ; : width 256 ; : height 256 ; : ( -- gadget ) - nehe2-gadget construct-gadget ; + nehe2-gadget new-gadget ; M: nehe2-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; diff --git a/extra/nehe/3/3.factor b/extra/nehe/3/3.factor index fff58380d6..8a2149e370 100644 --- a/extra/nehe/3/3.factor +++ b/extra/nehe/3/3.factor @@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui ui.gadgets ui.render ; IN: nehe.3 -TUPLE: nehe3-gadget ; +TUPLE: nehe3-gadget < gadget ; : width 256 ; : height 256 ; : ( -- gadget ) - nehe3-gadget construct-gadget ; + nehe3-gadget new-gadget ; M: nehe3-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index b87b4a2308..fc2727159b 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -2,14 +2,14 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui ui.gadgets ui.render threads ; IN: nehe.4 -TUPLE: nehe4-gadget rtri rquad thread quit? ; +TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; : width 256 ; : height 256 ; : redraw-interval 10 ; : ( -- gadget ) - nehe4-gadget construct-gadget + nehe4-gadget new-gadget 0.0 over set-nehe4-gadget-rtri 0.0 over set-nehe4-gadget-rquad ; diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor index 31a7d059ae..f399a116ed 100755 --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui ui.gadgets ui.render threads ; IN: nehe.5 -TUPLE: nehe5-gadget rtri rquad thread quit? ; +TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; : width 256 ; : height 256 ; : redraw-interval 10 ; : ( -- gadget ) - nehe5-gadget construct-gadget + nehe5-gadget new-gadget 0.0 over set-nehe5-gadget-rtri 0.0 over set-nehe5-gadget-rquad ; From c1328ac08e0500dcce7bba0c600d13cd386da884 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 12:22:27 -0500 Subject: [PATCH 30/73] math.physics.pos: distance method --- extra/math/physics/pos/pos.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/extra/math/physics/pos/pos.factor b/extra/math/physics/pos/pos.factor index 1582c42108..69155686c8 100644 --- a/extra/math/physics/pos/pos.factor +++ b/extra/math/physics/pos/pos.factor @@ -1,5 +1,17 @@ +USING: kernel sequences multi-methods accessors math.vectors ; + IN: math.physics.pos TUPLE: pos pos ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: distance ( a b -- c ) + +METHOD: distance { sequence sequence } v- norm ; + +METHOD: distance { pos pos } [ pos>> ] bi@ distance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 3bb6d9e57256fb17ee63ab7022bf2645f22f1233 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 12:29:51 -0500 Subject: [PATCH 31/73] boids: use 'distance' method --- extra/boids/boids.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index cff33c9d19..ab624a606b 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -73,10 +73,6 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : constrain ( n a b -- n ) rot min max ; : angle-between ( vec vec -- angle ) From 4a9363091ec9bfae869eb3ba2fe2a9243d295998 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 13:05:51 -0500 Subject: [PATCH 32/73] springies: use new accessors --- extra/springies/springies.factor | 46 ++++++++++++++------------------ 1 file changed, 20 insertions(+), 26 deletions(-) diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index fb69783975..818aa675e2 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -28,16 +28,10 @@ VAR: gravity ! node ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TUPLE: node mass elas pos vel force ; - TUPLE: node < vel mass elas force ; C: node -! : >>pos ( node pos -- node ) over set-node-pos ; - -! : >>vel ( node vel -- node ) over set-node-vel ; - : node-vel ( node -- vel ) vel>> ; : set-node-vel ( vel node -- ) swap >>vel drop ; @@ -52,9 +46,9 @@ C: node : >>vel-x ( node x -- node ) over vel>> set-first ; : >>vel-y ( node y -- node ) over vel>> set-second ; -: apply-force ( node vec -- ) over node-force v+ swap set-node-force ; +: apply-force ( node vec -- ) over force>> v+ >>force drop ; -: reset-force ( node -- ) 0 0 2array swap set-node-force ; +: reset-force ( node -- node ) 0 0 2array >>force ; : node-id ( id -- node ) 1- nodes> nth ; @@ -67,12 +61,12 @@ TUPLE: spring rest-length k damp node-a node-b ; C: spring : end-points ( spring -- b-pos a-pos ) - [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi ; + [ node-b>> pos>> ] [ node-a>> pos>> ] bi ; : spring-length ( spring -- length ) end-points v- norm ; : stretch-length ( spring -- length ) - [ spring-length ] [ spring-rest-length ] bi - ; + [ spring-length ] [ rest-length>> ] bi - ; : dir ( spring -- vec ) end-points v- normalize ; @@ -87,14 +81,14 @@ C: spring ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: hooke-force-mag ( spring -- mag ) [ spring-k ] [ stretch-length ] bi * ; +: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ; : hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ; : hooke-forces ( spring -- a b ) hooke-force dup vneg ; : act-on-nodes-hooke ( spring -- ) - [ spring-node-a ] [ spring-node-b ] [ ] tri hooke-forces swapd + [ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd apply-force apply-force ; @@ -118,37 +112,37 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-a ( spring -- vel ) - [ spring-node-a vel>> ] [ spring-node-b vel>> ] bi v- ; + [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ; : unit-vec-b->a ( spring -- vec ) - [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi v- ; + [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ; : relative-velocity-along-spring-a ( spring -- vel ) [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ; : damping-force-a ( spring -- vec ) - [ relative-velocity-along-spring-a ] [ spring-damp ] bi v*n vneg ; + [ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-b ( spring -- vel ) - [ spring-node-b vel>> ] [ spring-node-a vel>> ] bi v- ; + [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ; : unit-vec-a->b ( spring -- vec ) - [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi v- ; + [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ; : relative-velocity-along-spring-b ( spring -- vel ) [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ; : damping-force-b ( spring -- vec ) - [ relative-velocity-along-spring-b ] [ spring-damp ] bi v*n vneg ; + [ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : act-on-nodes-damping ( spring -- ) dup - [ spring-node-a ] [ damping-force-a ] bi apply-force - [ spring-node-b ] [ damping-force-b ] bi apply-force ; + [ node-a>> ] [ damping-force-a ] bi apply-force + [ node-b>> ] [ damping-force-b ] bi apply-force ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -164,22 +158,22 @@ C: spring : bounce-top ( node -- ) world-height 1- >>pos-y - dup [ vel-y ] [ node-elas ] bi * neg >>vel-y + dup [ vel-y ] [ elas>> ] bi * neg >>vel-y drop ; : bounce-bottom ( node -- ) 0 >>pos-y - dup [ vel-y ] [ node-elas ] bi * neg >>vel-y + dup [ vel-y ] [ elas>> ] bi * neg >>vel-y drop ; : bounce-left ( node -- ) 0 >>pos-x - dup [ vel-x ] [ node-elas ] bi * neg >>vel-x + dup [ vel-x ] [ elas>> ] bi * neg >>vel-x drop ; : bounce-right ( node -- ) world-width 1- >>pos-x - dup [ vel-x ] [ node-elas ] bi * neg >>vel-x + dup [ vel-x ] [ elas>> ] bi * neg >>vel-x drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -213,7 +207,7 @@ C: spring ! F = ma -: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ; +: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ; : new-vel ( node -- vel ) [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ; @@ -223,7 +217,7 @@ C: spring : iterate-node ( node -- ) dup new-pos >>pos dup new-vel >>vel - dup reset-force + reset-force handle-bounce ; : iterate-nodes ( -- ) nodes> [ iterate-node ] each ; From 8160859c8b61cb63bb0308a959d1920b3f0ad21f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 13:12:45 -0500 Subject: [PATCH 33/73] Fixes --- core/classes/tuple/parser/parser-tests.factor | 2 +- core/optimizer/math/math.factor | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 10cbe268da..d40b71b477 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -51,7 +51,7 @@ must-fail-with [ error>> unexpected-eof? ] must-fail-with -[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ] +[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] [ error>> no-initial-value? ] must-fail-with diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 799f4d80cf..b208a9f894 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -444,7 +444,10 @@ most-negative-fixnum most-positive-fixnum [a,b] { /f < > <= >= } [ { real real } "input-classes" set-word-prop ] each -{ /i bitand bitor bitxor bitnot shift } +{ /i mod /mod } +[ { rational rational } "input-classes" set-word-prop ] each + +{ bitand bitor bitxor bitnot shift } [ { integer integer } "input-classes" set-word-prop ] each { From 80a38f8990d473fa5bc63709ce44357c8df0413b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:48:20 -0500 Subject: [PATCH 34/73] boids.ui: use newfx --- extra/boids/ui/ui.factor | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index ab1f8e5f80..b1f594b8c2 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -20,7 +20,8 @@ USING: combinators.short-circuit kernel namespaces ui.gadgets.grids ui.gestures assocs.lib vars rewrite-closures boids accessors - math.geometry.rect ; + math.geometry.rect + newfx ; IN: boids.ui @@ -145,20 +146,20 @@ VARS: population-label cohesion-label alignment-label separation-label ; slate> over @center grid-add H{ } clone - T{ key-down f f "1" } C[ drop randomize ] put-at - T{ key-down f f "2" } C[ drop sub-10-boids ] put-at - T{ key-down f f "3" } C[ drop add-10-boids ] put-at + T{ key-down f f "1" } C[ drop randomize ] is + T{ key-down f f "2" } C[ drop sub-10-boids ] is + T{ key-down f f "3" } C[ drop add-10-boids ] is - T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at - T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at + T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is + T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is - T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at - T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at + T{ key-down f f "w" } C[ drop inc-alignment-weight ] is + T{ key-down f f "s" } C[ drop dec-alignment-weight ] is - T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at - T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at + T{ key-down f f "e" } C[ drop inc-separation-weight ] is + T{ key-down f f "d" } C[ drop dec-separation-weight ] is - T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at + T{ key-down f f "ESC" } C[ drop toggle-loop ] is tuck set-gadget-delegate "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; From 44c2b9823de331a9ab3e97cf63704693d0108904 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:49:14 -0500 Subject: [PATCH 35/73] assocs.lib: remove old code --- extra/assocs/lib/lib.factor | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 14632df771..5036a13d78 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,13 +1,8 @@ USING: arrays assocs kernel vectors sequences namespaces -random math.parser math fry ; + random math.parser math fry ; + IN: assocs.lib -: ref-at ( table key -- value ) swap at ; - -: put-at* ( table key value -- ) swap rot set-at ; - -: put-at ( table key value -- table ) swap pick set-at ; - : set-assoc-stack ( value key seq -- ) dupd [ key? ] with find-last nip set-at ; From 2374b4293d0c35cad3137a5ac086f781fd5ae2ca Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:53:20 -0500 Subject: [PATCH 36/73] automata: no need for >array when using --- extra/automata/automata.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index a70eaa063d..979a733692 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -32,7 +32,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; ! step-wrapped-line ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: pattern>state ( {_a_b_c_} -- state ) >array rule> at ; +: pattern>state ( {_a_b_c_} -- state ) rule> at ; : cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ; From 5decac30d2861c4649c8c08ca131cd9c32f206ea Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 16:46:50 -0500 Subject: [PATCH 37/73] automata.ui: new automata-window* --- extra/automata/ui/ui.factor | 65 +++++++++++++++++++++++++------------ 1 file changed, 44 insertions(+), 21 deletions(-) diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index cfec6597c2..5678a6f06b 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -14,13 +14,25 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.packs ui.gadgets.grids ui.gadgets.theme + accessors + qualified namespaces.lib assocs.lib vars - rewrite-closures automata math.geometry.rect ; + rewrite-closures automata math.geometry.rect newfx ; IN: automata.ui ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +QUALIFIED: ui.gadgets +QUALIFIED: ui.gadgets.grids + +: add-gadget ( parent child -- parent ) over ui.gadgets:add-gadget ; + +: grid-add ( grid child i j -- grid ) + >r >r dupd swap r> r> ui.gadgets.grids:grid-add ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ; : draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ; @@ -57,29 +69,40 @@ slate> relayout-1 ; DEFER: automata-window -: automata-window* ( -- ) init-rule set-interesting +: automata-window* ( -- ) + init-rule + set-interesting -{ -[ "1 - Center" [ start-center ] view-button ] -[ "2 - Random" [ start-random ] view-button ] -[ "3 - Continue" [ run-rule ] view-button ] -[ "5 - Random Rule" [ random-rule ] view-button ] -[ "n - New" [ automata-window ] view-button ] -} make* -[ [ gadget, ] curry ] map concat ! Hack -make-shelf over @top grid-add + -[ display ] closed-quot { 400 400 } over set-slate-dim dup >slate -over @center grid-add + -{ -{ T{ key-down f f "1" } [ [ start-center ] view-action ] } -{ T{ key-down f f "2" } [ [ start-random ] view-action ] } -{ T{ key-down f f "3" } [ [ run-rule ] view-action ] } -{ T{ key-down f f "5" } [ [ random-rule ] view-action ] } -{ T{ key-down f f "n" } [ [ automata-window ] view-action ] } -} [ make* ] map >hashtable tuck set-gadget-delegate -"Automata" open-window ; + "1 - Center" [ start-center ] view-button add-gadget + "2 - Random" [ start-random ] view-button add-gadget + "3 - Continue" [ run-rule ] view-button add-gadget + "5 - Random Rule" [ random-rule ] view-button add-gadget + "n - New" [ automata-window ] view-button add-gadget + + @top grid-add + + C[ display ] + { 400 400 } >>dim + dup >slate + + @center grid-add + + H{ } + T{ key-down f f "1" } [ start-center ] view-action is + T{ key-down f f "2" } [ start-random ] view-action is + T{ key-down f f "3" } [ run-rule ] view-action is + T{ key-down f f "5" } [ random-rule ] view-action is + T{ key-down f f "n" } [ automata-window ] view-action is + + + + tuck set-gadget-delegate + + "Automata" open-window ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From e16aa9ead3c2873e3def98f8904d0f5f8238af18 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:45:57 -0500 Subject: [PATCH 38/73] ui.gadgets: update parent accessors --- extra/ui/gadgets/gadgets.factor | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index a274dc2392..fcb6c765a3 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -12,10 +12,10 @@ SYMBOL: ui-notify-flag : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; TUPLE: gadget < rect -pref-dim parent children orientation focus -visible? root? clipped? layout-state graft-state graft-node -interior boundary -model ; + pref-dim parent children orientation focus + visible? root? clipped? layout-state graft-state graft-node + interior boundary + model ; M: gadget equal? 2drop f ; @@ -58,7 +58,7 @@ M: gadget model-changed 2drop ; 2drop { 0 0 } ] [ over rect-loc >r - >r gadget-parent r> relative-loc + >r parent>> r> relative-loc r> v+ ] if ; @@ -150,7 +150,7 @@ DEFER: relayout \ invalidate* over set-gadget-layout-state dup forget-pref-dim dup gadget-root? - [ layout-later ] [ gadget-parent [ relayout ] when* ] if ; + [ layout-later ] [ parent>> [ relayout ] when* ] if ; : relayout ( gadget -- ) dup gadget-layout-state \ invalidate* eq? @@ -255,7 +255,7 @@ M: gadget ungraft* drop ; : (unparent) ( gadget -- ) dup ungraft dup forget-pref-dim - f swap set-gadget-parent ; + f swap (>>parent) ; : unfocus-gadget ( child gadget -- ) tuck gadget-focus eq? @@ -270,7 +270,7 @@ SYMBOL: in-layout? : unparent ( gadget -- ) not-in-layout [ - dup gadget-parent dup [ + dup parent>> dup [ over (unparent) [ unfocus-gadget ] 2keep [ gadget-children delete ] keep @@ -294,7 +294,7 @@ SYMBOL: in-layout? : (add-gadget) ( gadget box -- ) over unparent - dup pick set-gadget-parent + dup pick (>>parent) [ ((add-gadget)) ] 2keep gadget-graft-state second [ graft ] [ drop ] if ; @@ -307,7 +307,7 @@ SYMBOL: in-layout? swap [ over (add-gadget) ] each relayout ; : parents ( gadget -- seq ) - [ gadget-parent ] follow ; + [ parent>> ] follow ; : each-parent ( gadget quot -- ? ) >r parents r> all? ; inline @@ -319,7 +319,7 @@ SYMBOL: in-layout? parents { 0 0 } [ rect-loc v+ ] reduce ; : (screen-rect) ( gadget -- loc ext ) - dup gadget-parent [ + dup parent>> [ >r rect-extent r> (screen-rect) >r tuck v+ r> vmin >r v+ r> ] [ @@ -333,7 +333,7 @@ SYMBOL: in-layout? { { [ 2dup eq? ] [ 2drop t ] } { [ dup not ] [ 2drop f ] } - [ gadget-parent child? ] + [ parent>> child? ] } cond ; GENERIC: focusable-child* ( gadget -- child/t ) @@ -346,7 +346,7 @@ M: gadget focusable-child* drop t ; GENERIC: request-focus-on ( child gadget -- ) -M: gadget request-focus-on gadget-parent request-focus-on ; +M: gadget request-focus-on parent>> request-focus-on ; M: f request-focus-on 2drop ; @@ -371,7 +371,7 @@ M: f request-focus-on 2drop ; ! Deprecated : set-gadget-delegate ( gadget tuple -- ) over [ - dup pick [ set-gadget-parent ] with each-child + dup pick [ (>>parent) ] with each-child ] when set-delegate ; : construct-gadget ( class -- tuple ) From a4678cc758d0813e4502badedaad9a20755230f1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:48:08 -0500 Subject: [PATCH 39/73] ui.gadgets: update children accessors --- extra/ui/gadgets/gadgets.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index fcb6c765a3..62d01d844b 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -23,9 +23,9 @@ M: gadget hashcode* drop gadget hashcode* ; M: gadget model-changed 2drop ; -: gadget-child ( gadget -- child ) gadget-children first ; +: gadget-child ( gadget -- child ) children>> first ; -: nth-gadget ( n gadget -- child ) gadget-children nth ; +: nth-gadget ( n gadget -- child ) children>> nth ; : new-gadget ( class -- gadget ) new @@ -68,7 +68,7 @@ M: gadget user-input* 2drop t ; GENERIC: children-on ( rect/point gadget -- seq ) -M: gadget children-on nip gadget-children ; +M: gadget children-on nip children>> ; : (fast-children-on) ( dim axis gadgets -- i ) swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; @@ -100,7 +100,7 @@ M: gadget children-on nip gadget-children ; >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ; : each-child ( gadget quot -- ) - >r gadget-children r> each ; inline + >r children>> r> each ; inline ! Selection protocol GENERIC: gadget-selection? ( gadget -- ? ) @@ -124,7 +124,7 @@ M: gadget gadget-text-separator [ dup % ] [ gadget-text* ] interleave drop ; M: gadget gadget-text* - dup gadget-children swap gadget-seq-text ; + dup children>> swap gadget-seq-text ; M: array gadget-text* [ gadget-text* ] each ; @@ -273,7 +273,7 @@ SYMBOL: in-layout? dup parent>> dup [ over (unparent) [ unfocus-gadget ] 2keep - [ gadget-children delete ] keep + [ children>> delete ] keep relayout ] [ 2drop @@ -283,14 +283,14 @@ SYMBOL: in-layout? : (clear-gadget) ( gadget -- ) dup [ (unparent) ] each-child f over set-gadget-focus - f swap set-gadget-children ; + f swap (>>children) ; : clear-gadget ( gadget -- ) not-in-layout dup (clear-gadget) relayout ; : ((add-gadget)) ( gadget box -- ) - [ gadget-children ?push ] keep set-gadget-children ; + [ children>> ?push ] keep (>>children) ; : (add-gadget) ( gadget box -- ) over unparent From 33da43aa907b7d392bab6551d31137b552dd8010 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:54:57 -0500 Subject: [PATCH 40/73] ui.gadgets: more accessor updates --- extra/ui/gadgets/gadgets.factor | 46 ++++++++++++++++----------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 62d01d844b..6f49791164 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -37,7 +37,7 @@ M: gadget model-changed 2drop ; gadget new-gadget ; : activate-control ( gadget -- ) - dup gadget-model dup [ + dup model>> dup [ 2dup add-connection swap model-changed ] [ @@ -45,13 +45,13 @@ M: gadget model-changed 2drop ; ] if ; : deactivate-control ( gadget -- ) - dup gadget-model dup [ 2dup remove-connection ] when 2drop ; + dup model>> dup [ 2dup remove-connection ] when 2drop ; : control-value ( control -- value ) - gadget-model model-value ; + model>> model-value ; : set-control-value ( value control -- ) - gadget-model set-model ; + model>> set-model ; : relative-loc ( fromgadget togadget -- loc ) 2dup eq? [ @@ -83,7 +83,7 @@ M: gadget children-on nip children>> ; r> ; : inside? ( bounds gadget -- ? ) - dup gadget-visible? [ intersects? ] [ 2drop f ] if ; + dup visible?>> [ intersects? ] [ 2drop f ] if ; : (pick-up) ( point gadget -- gadget ) dupd children-on [ inside? ] with find-last nip ; @@ -97,7 +97,7 @@ M: gadget children-on nip children>> ; : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ; : orient ( gadget seq1 seq2 -- seq ) - >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ; + >r >r orientation>> r> r> [ pick set-axis ] 2map nip ; : each-child ( gadget quot -- ) >r children>> r> each ; inline @@ -117,7 +117,7 @@ GENERIC: gadget-text* ( gadget -- ) GENERIC: gadget-text-separator ( gadget -- str ) M: gadget gadget-text-separator - gadget-orientation { 0 1 } = "\n" "" ? ; + orientation>> { 0 1 } = "\n" "" ? ; : gadget-seq-text ( seq gadget -- ) gadget-text-separator swap @@ -132,9 +132,9 @@ M: array gadget-text* : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ; : invalidate ( gadget -- ) - \ invalidate swap set-gadget-layout-state ; + \ invalidate swap (>>layout-state) ; -: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ; +: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ; : layout-queue ( -- queue ) \ layout-queue get ; @@ -147,22 +147,22 @@ M: array gadget-text* DEFER: relayout : invalidate* ( gadget -- ) - \ invalidate* over set-gadget-layout-state + \ invalidate* over (>>layout-state) dup forget-pref-dim dup gadget-root? [ layout-later ] [ parent>> [ relayout ] when* ] if ; : relayout ( gadget -- ) - dup gadget-layout-state \ invalidate* eq? + dup layout-state>> \ invalidate* eq? [ drop ] [ invalidate* ] if ; : relayout-1 ( gadget -- ) - dup gadget-layout-state + dup layout-state>> [ drop ] [ dup invalidate layout-later ] if ; -: show-gadget ( gadget -- ) t swap set-gadget-visible? ; +: show-gadget ( gadget -- ) t swap (>>visible?) ; -: hide-gadget ( gadget -- ) f swap set-gadget-visible? ; +: hide-gadget ( gadget -- ) f swap (>>visible?) ; : (set-rect-dim) ( dim gadget quot -- ) >r 2dup rect-dim = @@ -178,11 +178,11 @@ DEFER: relayout GENERIC: pref-dim* ( gadget -- dim ) : ?set-gadget-pref-dim ( dim gadget -- ) - dup gadget-layout-state - [ 2drop ] [ set-gadget-pref-dim ] if ; + dup layout-state>> + [ 2drop ] [ (>>pref-dim) ] if ; : pref-dim ( gadget -- dim ) - dup gadget-pref-dim [ ] [ + dup pref-dim>> [ ] [ [ pref-dim* dup ] keep ?set-gadget-pref-dim ] ?if ; @@ -196,10 +196,10 @@ M: gadget layout* drop ; : prefer ( gadget -- ) dup pref-dim swap set-layout-dim ; -: validate ( gadget -- ) f swap set-gadget-layout-state ; +: validate ( gadget -- ) f swap (>>layout-state) ; : layout ( gadget -- ) - dup gadget-layout-state [ + dup layout-state>> [ dup validate dup layout* dup [ layout ] each-child @@ -258,8 +258,8 @@ M: gadget ungraft* drop ; f swap (>>parent) ; : unfocus-gadget ( child gadget -- ) - tuck gadget-focus eq? - [ f swap set-gadget-focus ] [ drop ] if ; + tuck focus>> eq? + [ f swap (>>focus) ] [ drop ] if ; SYMBOL: in-layout? @@ -282,7 +282,7 @@ SYMBOL: in-layout? : (clear-gadget) ( gadget -- ) dup [ (unparent) ] each-child - f over set-gadget-focus + f over (>>focus) f swap (>>children) ; : clear-gadget ( gadget -- ) @@ -354,7 +354,7 @@ M: f request-focus-on 2drop ; [ focusable-child ] keep request-focus-on ; : focus-path ( world -- seq ) - [ gadget-focus ] follow ; + [ focus>> ] follow ; : gadget, ( gadget -- ) gadget get add-gadget ; From 80783019c2773a0416d304baac7b4ce32b11a3cd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:57:57 -0500 Subject: [PATCH 41/73] ui.gadgets: cleaner fast-children-on --- extra/ui/gadgets/gadgets.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 6f49791164..f5e1f35081 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -74,13 +74,9 @@ M: gadget children-on nip children>> ; swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; : fast-children-on ( rect axis children -- from to ) - 3dup - >r >r dup rect-loc swap rect-dim v+ - r> r> (fast-children-on) ?1+ - >r - >r >r rect-loc - r> r> (fast-children-on) 0 or - r> ; + [ >r >r rect-loc r> r> (fast-children-on) 0 or ] + [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] + 3bi ; : inside? ( bounds gadget -- ? ) dup visible?>> [ intersects? ] [ 2drop f ] if ; From 49f58ce15b30a06c5cc6eda1a67f40bdd2b1fed5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:58:44 -0500 Subject: [PATCH 42/73] ui.gadgets: proper indentation --- extra/ui/gadgets/gadgets.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index f5e1f35081..59041c6115 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -74,9 +74,9 @@ M: gadget children-on nip children>> ; swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; : fast-children-on ( rect axis children -- from to ) - [ >r >r rect-loc r> r> (fast-children-on) 0 or ] - [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] - 3bi ; + [ >r >r rect-loc r> r> (fast-children-on) 0 or ] + [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] + 3bi ; : inside? ( bounds gadget -- ? ) dup visible?>> [ intersects? ] [ 2drop f ] if ; From 32ca39ce8580590003da788d5f35c49d8d0d0e9e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 18:02:32 -0500 Subject: [PATCH 43/73] ui.gadgets: more accessors updates --- extra/ui/gadgets/gadgets.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 59041c6115..3fc185a10e 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -219,7 +219,7 @@ M: gadget layout* drop ; { t f } (queue-graft) ; : graft-later ( gadget -- ) - dup gadget-graft-state { + dup graft-state>> { { { f t } [ drop ] } { { t t } [ drop ] } { { t f } [ unqueue-graft ] } @@ -227,7 +227,7 @@ M: gadget layout* drop ; } case ; : ungraft-later ( gadget -- ) - dup gadget-graft-state { + dup graft-state>> { { { f f } [ drop ] } { { t f } [ drop ] } { { f t } [ unqueue-graft ] } @@ -292,7 +292,7 @@ SYMBOL: in-layout? over unparent dup pick (>>parent) [ ((add-gadget)) ] 2keep - gadget-graft-state second [ graft ] [ drop ] if ; + graft-state>> second [ graft ] [ drop ] if ; : add-gadget ( gadget parent -- ) not-in-layout From 0770d50d7b67c810c571dfbe049faba0c7d53cc6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 18:52:31 -0500 Subject: [PATCH 44/73] Bi-assocs: fast at and value-at --- core/assocs/assocs.factor | 9 ++++--- extra/biassocs/biassocs-tests.factor | 22 +++++++++++++++++ extra/biassocs/biassocs.factor | 35 ++++++++++++++++++++++++++++ 3 files changed, 63 insertions(+), 3 deletions(-) create mode 100644 extra/biassocs/biassocs-tests.factor create mode 100644 extra/biassocs/biassocs.factor diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index f56ac810d9..6cb8958298 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -144,10 +144,13 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : extract-keys ( seq assoc -- subassoc ) [ [ dupd at ] curry ] keep map>assoc ; -! M: assoc >alist [ 2array ] { } assoc>map ; +GENERIC: value-at* ( value assoc -- key/f ? ) -: value-at ( value assoc -- key/f ) - swap [ = nip ] curry assoc-find 2drop ; +M: assoc value-at* swap [ = nip ] curry assoc-find nip ; + +: value-at ( value assoc -- key/f ) value-at* drop ; + +: value? ( value assoc -- ? ) value-at* nip ; : push-at ( value key assoc -- ) [ ?push ] change-at ; diff --git a/extra/biassocs/biassocs-tests.factor b/extra/biassocs/biassocs-tests.factor new file mode 100644 index 0000000000..4cd7f00f80 --- /dev/null +++ b/extra/biassocs/biassocs-tests.factor @@ -0,0 +1,22 @@ +IN: biassocs.tests +USING: biassocs assocs namespaces tools.test ; + + "h" set + +[ 0 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 2 "h" get set-at ] unit-test + +[ 1 ] [ 2 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 1 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 3 "h" get set-at ] unit-test + +[ 1 ] [ 3 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 2 ] [ "h" get assoc-size ] unit-test diff --git a/extra/biassocs/biassocs.factor b/extra/biassocs/biassocs.factor new file mode 100644 index 0000000000..9f12d04fc4 --- /dev/null +++ b/extra/biassocs/biassocs.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs accessors ; +IN: biassocs + +TUPLE: biassoc from to ; + +: ( exemplar -- biassoc ) + [ clone ] [ clone ] bi biassoc boa ; + +: ( -- bihashtable ) + H{ } ; + +M: biassoc assoc-size from>> assoc-size ; + +M: biassoc at* from>> at* ; + +M: biassoc value-at* to>> at* ; + +: once-at ( value key assoc -- ) + 2dup key? [ 3drop ] [ set-at ] if ; + +M: biassoc set-at + [ from>> set-at ] [ swapd to>> once-at ] 3bi ; + +M: biassoc delete-at + "biassocs do not support deletion" throw ; + +M: biassoc >alist + from>> >alist ; + +M: biassoc clear-assoc + [ from>> clear-assoc ] [ to>> clear-assoc ] bi ; + +INSTANCE: biassoc assoc From eda828169465529cb2bb05b21dbc1d237ad8470d Mon Sep 17 00:00:00 2001 From: erg Date: Sat, 12 Jul 2008 20:56:44 -0500 Subject: [PATCH 45/73] document conjoin --- core/sets/sets-docs.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 205d4d34bf..57d62f6480 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -38,6 +38,18 @@ HELP: adjoin } { $side-effects "seq" } ; +HELP: conjoin +{ $values { "elt" object } { "assoc" "an assoc" } } +{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." } +{ $examples + { $example + "USING: kernel prettyprint sets ;" + "H{ } clone 1 over conjoin ." + "H{ { 1 1 } }" + } +} +{ $side-effects "assoc" } ; + HELP: unique { $values { "seq" "a sequence" } { "assoc" "an assoc" } } { $description "Outputs a new assoc where the keys and values are equal." } From a700ec70418a6801f4bc364d2f3d48f8f9ea665e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 21:15:11 -0500 Subject: [PATCH 46/73] More efficient float arrayss; 15% improvement on spectral-norm --- core/alien/c-types/c-types.factor | 3 ++- extra/float-arrays/float-arrays.factor | 24 ++++++++---------------- 2 files changed, 10 insertions(+), 17 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index e576b87f52..405d679f4a 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -151,7 +151,8 @@ M: byte-array byte-length length ; swap dup length memcpy ; : (define-nth) ( word type quot -- ) - >r heap-size [ rot * ] swap prefix r> append define-inline ; + >r heap-size [ rot * >fixnum ] swap prefix + r> append define-inline ; : nth-word ( name vocab -- word ) >r "-nth" append r> create ; diff --git a/extra/float-arrays/float-arrays.factor b/extra/float-arrays/float-arrays.factor index 668bb7de41..0aa7fa5056 100755 --- a/extra/float-arrays/float-arrays.factor +++ b/extra/float-arrays/float-arrays.factor @@ -9,16 +9,8 @@ TUPLE: float-array { length array-capacity read-only } { underlying byte-array read-only } ; -bytes 8 * ; inline - -: float-array@ underlying>> swap >fixnum floats>bytes ; inline - -PRIVATE> - : ( n -- float-array ) - dup floats>bytes float-array boa ; inline + dup "double" float-array boa ; inline M: float-array clone [ length>> ] [ underlying>> clone ] bi float-array boa ; @@ -26,13 +18,13 @@ M: float-array clone M: float-array length length>> ; M: float-array nth-unsafe - float-array@ alien-double ; + underlying>> double-nth ; M: float-array set-nth-unsafe - [ >float ] 2dip float-array@ set-alien-double ; + [ >float ] 2dip underlying>> set-double-nth ; : >float-array ( seq -- float-array ) - T{ float-array f 0 B{ } } clone-like ; inline + T{ float-array } clone-like ; inline M: float-array like drop dup float-array? [ >float-array ] unless ; @@ -45,7 +37,7 @@ M: float-array equal? M: float-array resize [ drop ] [ - [ floats>bytes ] [ underlying>> ] bi* + [ "double" heap-size * ] [ underlying>> ] bi* resize-byte-array ] 2bi float-array boa ; @@ -58,13 +50,13 @@ INSTANCE: float-array sequence 1 [ set-first ] keep ; flushable : 2float-array ( x y -- array ) - T{ float-array f 0 B{ } } 2sequence ; flushable + T{ float-array } 2sequence ; flushable : 3float-array ( x y z -- array ) - T{ float-array f 0 B{ } } 3sequence ; flushable + T{ float-array } 3sequence ; flushable : 4float-array ( w x y z -- array ) - T{ float-array f 0 B{ } } 4sequence ; flushable + T{ float-array } 4sequence ; flushable : F{ ( parsed -- parsed ) \ } [ >float-array ] parse-literal ; parsing From f1879cb33788a91479ebb421d4f1fc8219a8447b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 21:28:43 -0500 Subject: [PATCH 47/73] Doc updates --- core/assocs/assocs-docs.factor | 20 +++++++++++++++++--- core/grouping/grouping-docs.factor | 4 ++++ extra/biassocs/authors.txt | 1 + extra/biassocs/biassocs-docs.factor | 28 ++++++++++++++++++++++++++++ extra/biassocs/biassocs.factor | 2 +- extra/biassocs/summary.txt | 1 + extra/biassocs/tags.txt | 1 + extra/bitfields/tags.txt | 1 - extra/lists/tags.txt | 4 +--- 9 files changed, 54 insertions(+), 8 deletions(-) create mode 100644 extra/biassocs/authors.txt create mode 100644 extra/biassocs/biassocs-docs.factor create mode 100644 extra/biassocs/summary.txt create mode 100644 extra/biassocs/tags.txt diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 0e1042391c..51293955d5 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -57,13 +57,19 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" { $subsection key? } { $subsection at } -{ $subsection value-at } { $subsection assoc-empty? } { $subsection keys } { $subsection values } { $subsection assoc-stack } { $see-also at* assoc-size } ; +ARTICLE: "assocs-values" "Transposed assoc operations" +"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:" +{ $subsection value-at } +{ $subsection value-at* } +{ $subsection value? } +"With most assoc implementations, these words runs in linear time, proportional to the number of entries in the assoc. For fast value lookups, use " { $vocab-link "biassocs" } "." ; + ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." { $subsection assoc-subset? } @@ -111,6 +117,7 @@ $nl { $subsection "assocs-protocol" } "A large set of utility words work on any object whose class implements the associative mapping protocol." { $subsection "assocs-lookup" } +{ $subsection "assocs-values" } { $subsection "assocs-mutation" } { $subsection "assocs-combinators" } { $subsection "assocs-sets" } ; @@ -231,10 +238,17 @@ HELP: assoc-stack { $description "Searches for the key in successive elements of the sequence, starting from the end. If an assoc containing the key is found, the associated value is output. If no assoc contains the key, outputs " { $link f } "." } { $notes "This word is used to implement abstractions such as nested scopes; if the sequence is a stack represented by a vector, then the most recently pushed assoc -- the innermost scope -- will be searched first." } ; +HELP: value-at* +{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } { "?" "a boolean" } } +{ $description "Looks up the key associated with a value. The boolean flag can decide beteen the case of a missing key, and a key of " { $link f } "." } ; + HELP: value-at { $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } } -{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } -{ $notes "This word runs in linear time, proportional to the number of entries in the assoc." } ; +{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } ; + +HELP: value? +{ $values { "value" "an object" } { "assoc" assoc } { "?" "a boolean" } } +{ $description "Tests if an assoc contains at least one key with the given value." } ; HELP: delete-at* { $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } } diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor index f7a37691a6..3b3a98eabd 100644 --- a/core/grouping/grouping-docs.factor +++ b/core/grouping/grouping-docs.factor @@ -2,10 +2,14 @@ USING: help.markup help.syntax sequences strings ; IN: grouping ARTICLE: "grouping" "Groups and clumps" +"Splitting a sequence into disjoint, fixed-length subsequences:" +{ $subsection group } "A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:" { $subsection groups } { $subsection } { $subsection } +"Splitting a sequence into overlapping, fixed-length subsequences:" +{ $subsection clump } "A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" { $subsection clumps } { $subsection } diff --git a/extra/biassocs/authors.txt b/extra/biassocs/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/biassocs/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/biassocs/biassocs-docs.factor b/extra/biassocs/biassocs-docs.factor new file mode 100644 index 0000000000..1fde3d05b3 --- /dev/null +++ b/extra/biassocs/biassocs-docs.factor @@ -0,0 +1,28 @@ +IN: biassocs +USING: help.markup help.syntax assocs kernel ; + +HELP: biassoc +{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ; + +HELP: +{ $values { "exemplar" assoc } { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ; + +HELP: +{ $values { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ; + +HELP: once-at +{ $values { "value" object } { "key" object } { "assoc" assoc } } +{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ; + +ARTICLE: "biassocs" "Bidirectional assocs" +"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." +$nl +"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." +{ $subsection biassoc } +{ $subsection biassoc? } +{ $subsection } +{ $subsection } ; + +ABOUT: "biassocs" diff --git a/extra/biassocs/biassocs.factor b/extra/biassocs/biassocs.factor index 9f12d04fc4..cd1e57f6ec 100644 --- a/extra/biassocs/biassocs.factor +++ b/extra/biassocs/biassocs.factor @@ -8,7 +8,7 @@ TUPLE: biassoc from to ; : ( exemplar -- biassoc ) [ clone ] [ clone ] bi biassoc boa ; -: ( -- bihashtable ) +: ( -- biassoc ) H{ } ; M: biassoc assoc-size from>> assoc-size ; diff --git a/extra/biassocs/summary.txt b/extra/biassocs/summary.txt new file mode 100644 index 0000000000..84c5b15afc --- /dev/null +++ b/extra/biassocs/summary.txt @@ -0,0 +1 @@ +Bidirectional assocs diff --git a/extra/biassocs/tags.txt b/extra/biassocs/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/biassocs/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/bitfields/tags.txt b/extra/bitfields/tags.txt index 9ffc038dbd..f4274299b1 100644 --- a/extra/bitfields/tags.txt +++ b/extra/bitfields/tags.txt @@ -1,2 +1 @@ -collections extensions diff --git a/extra/lists/tags.txt b/extra/lists/tags.txt index e44334b2b5..42d711b32b 100644 --- a/extra/lists/tags.txt +++ b/extra/lists/tags.txt @@ -1,3 +1 @@ -cons -lists -sequences +collections From 16b85df5db54c427c036db81614dd49d836b52d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 22:27:28 -0500 Subject: [PATCH 48/73] Fixes and a small optiimization --- core/bootstrap/image/image.factor | 3 +++ core/cpu/x86/bootstrap.factor | 6 +++++ core/generator/fixup/fixup.factor | 1 + core/inference/errors/errors.factor | 6 ++--- core/optimizer/def-use/def-use.factor | 5 ++-- core/optimizer/known-words/known-words.factor | 18 ++++++------- core/optimizer/math/math.factor | 8 +++--- .../pattern-match/pattern-match.factor | 5 ++-- extra/optimizer/debugger/debugger.factor | 10 +++---- vm/code_heap.c | 2 ++ vm/code_heap.h | 4 ++- vm/quotations.c | 5 ++-- vm/run.h | 26 +++---------------- 13 files changed, 46 insertions(+), 53 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 632938bb2d..97a95f98b8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -119,6 +119,7 @@ SYMBOL: jit-primitive SYMBOL: jit-word-jump SYMBOL: jit-word-call SYMBOL: jit-push-literal +SYMBOL: jit-push-immediate SYMBOL: jit-if-word SYMBOL: jit-if-jump SYMBOL: jit-dispatch-word @@ -149,6 +150,7 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } + { jit-push-immediate 36 } { jit-declare-word 42 } { undefined-quot 60 } } at header-size + ; @@ -438,6 +440,7 @@ M: quotation ' jit-word-jump jit-word-call jit-push-literal + jit-push-immediate jit-if-word jit-if-jump jit-dispatch-word diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index bd90ca65f0..76a42b3f2d 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -40,6 +40,12 @@ big-endian off ds-reg [] arg0 MOV ! store literal on datastack ] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define +[ + arg0 0 MOV ! load literal + ds-reg bootstrap-cell ADD ! increment datastack pointer + ds-reg [] arg0 MOV ! store literal on datastack +] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define + [ arg0 0 MOV ! load XT arg1 stack-reg MOV ! pass callstack pointer as arg 2 diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 058822bf2f..9be8151bee 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -72,6 +72,7 @@ SYMBOL: label-table : rt-xt 4 ; : rt-here 5 ; : rt-label 6 ; +: rt-immediate 7 ; TUPLE: label-fixup label class ; diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index e1d5bd434c..9e01492529 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel generic sequences prettyprint io words arrays +summary effects debugger assocs accessors inference.backend +inference.dataflow ; IN: inference.errors -USING: inference.backend inference.dataflow kernel generic -sequences prettyprint io words arrays summary effects debugger -assocs accessors ; M: inference-error error-help error>> error-help ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index d4905a1718..55088fd7e2 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs sequences inference.dataflow -inference.backend kernel generic assocs classes vectors -accessors combinators ; +USING: namespaces assocs sequences kernel generic assocs classes +vectors accessors combinators inference.dataflow inference.backend ; IN: optimizer.def-use SYMBOL: def-use diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 76ad0009cb..7527199fe9 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien arrays generic hashtables definitions -inference.dataflow inference.state inference.class kernel assocs -math math.order math.private kernel.private sequences words -parser vectors strings sbufs io namespaces assocs quotations -sequences.private io.binary io.streams.string layouts splitting -math.intervals math.floats.private classes.tuple classes.predicate -classes.tuple.private classes classes.algebra optimizer.def-use -optimizer.backend optimizer.pattern-match optimizer.inlining -sequences.private combinators byte-arrays byte-vectors -slots.private ; +kernel assocs math math.order math.private kernel.private +sequences words parser vectors strings sbufs io namespaces +assocs quotations sequences.private io.binary io.streams.string +layouts splitting math.intervals math.floats.private +classes.tuple classes.predicate classes.tuple.private classes +classes.algebra sequences.private combinators byte-arrays +byte-vectors slots.private inference.dataflow inference.state +inference.class optimizer.def-use optimizer.backend +optimizer.pattern-match optimizer.inlining ; IN: optimizer.known-words { (tuple) } [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index b208a9f894..c20cba99cb 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: effects alien alien.accessors arrays generic hashtables kernel assocs math math.libm math.private kernel.private -sequences words parser inference.class inference.dataflow -vectors strings sbufs io namespaces assocs quotations -math.intervals sequences.private combinators splitting layouts -math.parser classes classes.algebra generic.math +sequences words parser vectors strings sbufs io namespaces +assocs quotations math.intervals sequences.private combinators +splitting layouts math.parser classes classes.algebra +generic.math inference.class inference.dataflow optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining optimizer.math.partial generic.standard system accessors ; diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor index 51fa254a25..647dda368f 100755 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces generic +combinators classes classes.algebra +inference inference.dataflow ; IN: optimizer.pattern-match -USING: kernel sequences inference namespaces generic -combinators classes classes.algebra inference.dataflow ; ! Funny pattern matching SYMBOL: @ diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index c20685cf70..2a79d8977f 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes inference inference.dataflow io kernel -kernel.private math.parser namespaces optimizer prettyprint -prettyprint.backend sequences words arrays match macros -assocs sequences.private optimizer.specializers generic -combinators sorting math quotations accessors ; +USING: classes io kernel kernel.private math.parser namespaces +optimizer prettyprint prettyprint.backend sequences words arrays +match macros assocs sequences.private generic combinators +sorting math quotations accessors inference inference.dataflow +optimizer.specializers ; IN: optimizer.debugger ! A simple tool for turning dataflow IR into quotations, for diff --git a/vm/code_heap.c b/vm/code_heap.c index 69ffdeb2aa..1435caa9d2 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -63,6 +63,8 @@ INLINE CELL compute_code_rel(F_REL *rel, return (CELL)get_rel_symbol(rel,literals_start); case RT_LITERAL: return CREF(literals_start,REL_ARGUMENT(rel)); + case RT_IMMEDIATE: + return get(CREF(literals_start,REL_ARGUMENT(rel))); case RT_XT: return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt; case RT_HERE: diff --git a/vm/code_heap.h b/vm/code_heap.h index 80605b1d28..c3b476c4b5 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -12,7 +12,9 @@ typedef enum { /* current offset */ RT_HERE, /* a local label */ - RT_LABEL + RT_LABEL, + /* immeditae literal */ + RT_IMMEDIATE } F_RELTYPE; typedef enum { diff --git a/vm/quotations.c b/vm/quotations.c index 2d54f23a6f..a1555136db 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -30,9 +30,8 @@ push the array and immediately drop it after. in the VM. They are open-coded and no subroutine call is generated. This includes stack shufflers, some fixnum arithmetic words, and words such as tag, slot and eq?. A primitive call is relatively expensive (two subroutine calls) -so this results in a big speedup for relatively little effort. +so this results in a big speedup for relatively little effort. */ -*/ bool jit_primitive_call_p(F_ARRAY *array, CELL i) { return (i + 2) == array_capacity(array) @@ -253,7 +252,7 @@ void jit_compile(CELL quot, bool relocate) } default: GROWABLE_ARRAY_ADD(literals,obj); - EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); + EMIT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],literals_count - 1); break; } } diff --git a/vm/run.h b/vm/run.h index 8a03049b93..96e606e38c 100755 --- a/vm/run.h +++ b/vm/run.h @@ -47,29 +47,9 @@ typedef enum { JIT_EPILOG, JIT_RETURN, JIT_PROFILING, - JIT_TAG, - JIT_TAG_WORD, - JIT_EQP, - JIT_EQP_WORD, - JIT_SLOT, - JIT_SLOT_WORD, - JIT_DECLARE_WORD, - JIT_DROP, - JIT_DROP_WORD, - JIT_DUP, - JIT_DUP_WORD, - JIT_TO_R, - JIT_TO_R_WORD, - JIT_FROM_R, - JIT_FROM_R_WORD, - JIT_SWAP, - JIT_SWAP_WORD, - JIT_OVER, - JIT_OVER_WORD, - JIT_FIXNUM_MINUS, - JIT_FIXNUM_MINUS_WORD, - JIT_FIXNUM_GE, - JIT_FIXNUM_GE_WORD, + JIT_PUSH_IMMEDIATE, + + JIT_DECLARE_WORD = 42, STACK_TRACES_ENV = 59, From 54b24fd8b1060c80362898744e797b5d285935d7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Jul 2008 01:24:43 -0500 Subject: [PATCH 49/73] ui.gadgets: new effects for add-gadget, add-gadgets, and (add-gadget) --- extra/ui/gadgets/gadgets.factor | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3fc185a10e..ebe3773ce9 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -285,22 +285,27 @@ SYMBOL: in-layout? not-in-layout dup (clear-gadget) relayout ; -: ((add-gadget)) ( gadget box -- ) - [ children>> ?push ] keep (>>children) ; +: ((add-gadget)) ( parent child -- parent ) + over children>> ?push >>children ; -: (add-gadget) ( gadget box -- ) - over unparent - dup pick (>>parent) - [ ((add-gadget)) ] 2keep - graft-state>> second [ graft ] [ drop ] if ; +: (add-gadget) ( parent child -- parent ) + dup unparent + over >>parent + tuck ((add-gadget)) + tuck graft-state>> second + [ graft ] + [ drop ] + if ; -: add-gadget ( gadget parent -- ) +: add-gadget ( parent child -- parent ) not-in-layout - [ (add-gadget) ] keep relayout ; - -: add-gadgets ( seq parent -- ) + (add-gadget) + dup relayout ; + +: add-gadgets ( parent children -- parent ) not-in-layout - swap [ over (add-gadget) ] each relayout ; + [ (add-gadget) ] each + dup relayout ; : parents ( gadget -- seq ) [ parent>> ] follow ; @@ -352,7 +357,7 @@ M: f request-focus-on 2drop ; : focus-path ( world -- seq ) [ focus>> ] follow ; -: gadget, ( gadget -- ) gadget get add-gadget ; +: gadget, ( gadget -- ) gadget get swap add-gadget drop ; : g ( -- gadget ) gadget get ; From 73e30123f52ae037b11f1977933c04e6e98f61fd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Jul 2008 01:25:44 -0500 Subject: [PATCH 50/73] ui.gadgets.*: updates for new effects --- extra/ui/gadgets/books/books.factor | 2 +- extra/ui/gadgets/borders/borders.factor | 2 +- extra/ui/gadgets/grids/grids.factor | 4 ++-- extra/ui/gadgets/incremental/incremental.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 2 +- extra/ui/gadgets/menus/menus.factor | 4 ++-- extra/ui/gadgets/panes/panes.factor | 12 ++++++------ extra/ui/gadgets/sliders/sliders.factor | 2 +- extra/ui/gadgets/tabs/tabs.factor | 4 ++-- extra/ui/gadgets/tracks/tracks.factor | 2 +- extra/ui/gadgets/viewports/viewports.factor | 2 +- extra/ui/gadgets/wrappers/wrappers.factor | 2 +- 12 files changed, 20 insertions(+), 20 deletions(-) diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index 93a8d271af..ce15bd9e6c 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -19,7 +19,7 @@ M: book model-changed : new-book ( pages model class -- book ) new-gadget swap >>model - [ add-gadgets ] keep ; inline + [ swap add-gadgets drop ] keep ; inline : ( pages model -- book ) book new-book ; diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 7d6a24fed1..d1cf7cfb29 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -10,7 +10,7 @@ TUPLE: border < gadget { align initial: { 1/2 1/2 } } ; : new-border ( child class -- border ) - new-gadget [ add-gadget ] keep ; inline + new-gadget [ swap add-gadget drop ] keep ; inline : ( child gap -- border ) swap border new-border diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor index b539934771..474e6b95c0 100644 --- a/extra/ui/gadgets/grids/grids.factor +++ b/extra/ui/gadgets/grids/grids.factor @@ -12,7 +12,7 @@ grid : new-grid ( children class -- grid ) new-gadget - [ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ; + [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ; inline : ( children -- grid ) @@ -21,7 +21,7 @@ grid : grid-child ( grid i j -- gadget ) rot grid>> nth nth ; : grid-add ( gadget grid i j -- ) - >r >r 2dup add-gadget r> r> + >r >r 2dup swap add-gadget drop r> r> 3dup grid-child unparent rot grid>> nth set-nth ; : grid-remove ( grid i j -- ) diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index c74f6676ad..8c227d76ce 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -45,7 +45,7 @@ M: incremental pref-dim* : add-incremental ( gadget incremental -- ) not-in-layout - 2dup (add-gadget) + 2dup swap (add-gadget) drop over prefer-incremental over layout-later 2dup incremental-loc diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 776814853f..c2539e146a 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -48,7 +48,7 @@ TUPLE: list < pack index presenter color hook ; M: list model-changed nip dup clear-gadget - dup over add-gadgets + dup over swap add-gadgets drop bound-index ; : selected-rect ( list -- rect ) diff --git a/extra/ui/gadgets/menus/menus.factor b/extra/ui/gadgets/menus/menus.factor index 3e1145a8b6..4f815bc33d 100644 --- a/extra/ui/gadgets/menus/menus.factor +++ b/extra/ui/gadgets/menus/menus.factor @@ -15,7 +15,7 @@ TUPLE: menu-glass < gadget ; : ( menu world -- glass ) menu-glass new-gadget >r over menu-loc over set-rect-loc r> - [ add-gadget ] keep ; + [ swap add-gadget drop ] keep ; M: menu-glass layout* gadget-child prefer ; @@ -26,7 +26,7 @@ M: menu-glass layout* gadget-child prefer ; : show-glass ( gadget world -- ) over hand-clicked set-global [ hide-glass ] keep - [ add-gadget ] 2keep + [ swap add-gadget drop ] 2keep set-world-glass ; : show-menu ( gadget owner -- ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 973c8c5725..9b547ce544 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -22,10 +22,10 @@ selection-color caret mark selecting? ; drop ; : add-output ( current pane -- ) - [ set-pane-output ] [ add-gadget ] 2bi ; + [ set-pane-output ] [ swap add-gadget drop ] 2bi ; : add-current ( current pane -- ) - [ set-pane-current ] [ add-gadget ] 2bi ; + [ set-pane-current ] [ swap add-gadget drop ] 2bi ; : prepare-line ( pane -- ) [ clear-selection ] @@ -120,7 +120,7 @@ C: pane-stream GENERIC: write-gadget ( gadget stream -- ) M: pane-stream write-gadget - pane-stream-pane pane-current add-gadget ; + pane-stream-pane pane-current swap add-gadget drop ; M: style-stream write-gadget stream>> write-gadget ; @@ -299,12 +299,12 @@ M: paragraph dispose drop ; : gadget-write ( string gadget -- ) over empty? - [ 2drop ] [ >r