From 470c66c851cf37b1062e35b4f70eb7584b16d33e Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Wed, 6 Aug 2008 01:07:10 -0500 Subject: [PATCH 01/22] adding docs for 24 game --- extra/24-game/24-game-docs.factor | 67 +++++++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) create mode 100644 extra/24-game/24-game-docs.factor diff --git a/extra/24-game/24-game-docs.factor b/extra/24-game/24-game-docs.factor new file mode 100644 index 0000000000..12a558b2d2 --- /dev/null +++ b/extra/24-game/24-game-docs.factor @@ -0,0 +1,67 @@ +USING: help.markup help.syntax math kernel ; +IN: 24-game + +HELP: play-game ( -- ) +{ $description "Starts the game!" } +{ $examples + { $unchecked-example + "USE: 24-game" + "play-game" + "{ 8 2 1 2 }\n" + "Commands: { + - * / rot swap q }\n" + "swap\n" + "{ 8 2 2 1 }\n" + "Commands: { + - * / rot swap q }\n" + "-\n" + "{ 8 2 1 }\n" + "Commands: { + - * / rot swap q }\n" + "+\n" + "{ 8 3 }\n" + "Commands: { + - * / swap q }\n" + "*\n" + "You WON!" + } +} ; + +HELP: 24-able ( -- vector ) +{ $values { "vector" "vector of 4 integers" } } +{ $description + "Produces a vector with 4 integers. With the following condition: " + "If these integers were directly on the stack, one can process them into 24, " + "just using the provided commands and the 4 numbers. The Following are the " + "provided commands: " + { $link + } ", " { $link - } ", " { $link * } ", " + { $link / } ", and " { $link swap } "." +} +{ $examples + { $example + "USE: 24-game" + "24-able vector-24-able?" + "t" + } + { $notes { $link 24-able? } " is used in " { $link 24-able } "." } +} ; + +HELP: 24-able? ( quad -- t/f ) +{ $values + { "quad" "vector of 4 integers" } + { "t/f" "a boolean" } +} +{ $description + "Tells if it is possible to win 24-game if it was initiated " + "with this sequence." +} ; + +HELP: build-quad ( -- array ) +{ $values + { "vector" "an array of 4 numbers" } +} +{ $description "Builds an array of 4 random numbers." } ; +ARTICLE: "24-game" "The Game of 24" +"A classic math game, where one attempts to create 24, by applying " +"arithmetical operations and some shuffle words to a stack of 4 numbers. " +{ $subsection play-game } +{ $subsection 24-able } +{ $subsection 24-able? } +{ $subsection build-quad } ; +ABOUT: "24-game" \ No newline at end of file From 6087776341313633647d8708d0d598634e71125e Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Wed, 6 Aug 2008 01:08:01 -0500 Subject: [PATCH 02/22] that would be me --- extra/24-game/authors.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/24-game/authors.txt diff --git a/extra/24-game/authors.txt b/extra/24-game/authors.txt new file mode 100644 index 0000000000..137b1605da --- /dev/null +++ b/extra/24-game/authors.txt @@ -0,0 +1 @@ +Reginald Ford \ No newline at end of file From e1f8e318bd07befa9968c9c9e2e37addde0c4227 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Wed, 6 Aug 2008 01:08:40 -0500 Subject: [PATCH 03/22] that's me --- extra/math/derivatives/authors.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/math/derivatives/authors.txt diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt new file mode 100644 index 0000000000..137b1605da --- /dev/null +++ b/extra/math/derivatives/authors.txt @@ -0,0 +1 @@ +Reginald Ford \ No newline at end of file From 5a9f05e2273b1a48a113455804a8cd5e6aacc072 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Wed, 6 Aug 2008 01:09:36 -0500 Subject: [PATCH 04/22] it's all me, baby --- extra/math/function-tools/authors.txt | 1 + extra/math/newtons-method/authors.txt | 1 + extra/math/secant-method/authors.txt | 1 + 3 files changed, 3 insertions(+) create mode 100644 extra/math/function-tools/authors.txt create mode 100644 extra/math/newtons-method/authors.txt create mode 100644 extra/math/secant-method/authors.txt diff --git a/extra/math/function-tools/authors.txt b/extra/math/function-tools/authors.txt new file mode 100644 index 0000000000..137b1605da --- /dev/null +++ b/extra/math/function-tools/authors.txt @@ -0,0 +1 @@ +Reginald Ford \ No newline at end of file diff --git a/extra/math/newtons-method/authors.txt b/extra/math/newtons-method/authors.txt new file mode 100644 index 0000000000..137b1605da --- /dev/null +++ b/extra/math/newtons-method/authors.txt @@ -0,0 +1 @@ +Reginald Ford \ No newline at end of file diff --git a/extra/math/secant-method/authors.txt b/extra/math/secant-method/authors.txt new file mode 100644 index 0000000000..137b1605da --- /dev/null +++ b/extra/math/secant-method/authors.txt @@ -0,0 +1 @@ +Reginald Ford \ No newline at end of file From 10448f809798c6941b525e114bab98065c2430bd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 6 Aug 2008 11:38:09 -0700 Subject: [PATCH 05/22] game-input.backend: follow eval to its new home --- extra/game-input/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/game-input/backend/backend.factor b/extra/game-input/backend/backend.factor index a31b9d6649..cfba0a52f5 100644 --- a/extra/game-input/backend/backend.factor +++ b/extra/game-input/backend/backend.factor @@ -1,4 +1,4 @@ -USING: multiline system parser combinators ; +USING: eval multiline system combinators ; IN: game-input.backend STRING: set-backend-for-macosx From 554bc131fe6d2049a9caf537a12dbc8e4394782b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Aug 2008 14:23:09 -0500 Subject: [PATCH 06/22] cfdg: Two new macros: rule and rules --- extra/cfdg/cfdg.factor | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 6cbbc51786..114ebf5445 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -5,7 +5,7 @@ USING: kernel alien.c-types combinators namespaces arrays opengl.gl opengl.glu opengl ui ui.gadgets.slate vars colors self self.slots random-weighted colors.hsv cfdg.gl accessors - ui.gadgets.handler ui.gestures assocs ui.gadgets ; + ui.gadgets.handler ui.gestures assocs ui.gadgets macros ; IN: cfdg @@ -137,6 +137,25 @@ VAR: threshold ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: [rules] ( seq -- quot ) + [ unclip swap [ [ do ] curry ] map concat 2array ] map + [ call-random-weighted ] swap prefix + [ when ] swap prefix + [ iterate? ] swap append ; + +MACRO: rules ( seq -- quot ) [rules] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: [rule] ( seq -- quot ) + [ [ do ] swap prefix ] map concat + [ when ] swap prefix + [ iterate? ] prepend ; + +MACRO: rule ( seq -- quot ) [rule] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: background : set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ; From eeb22dafaba79f66f9263d8a1c2e8fb0d8ea3133 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Aug 2008 14:23:31 -0500 Subject: [PATCH 07/22] demos: Align text --- extra/demos/demos.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor index c8e5a35f9e..40149bafa9 100644 --- a/extra/demos/demos.factor +++ b/extra/demos/demos.factor @@ -10,7 +10,7 @@ IN: demos : demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ; : ( vocab-name -- button ) - dup '[ drop [ , run ] call-listener ] ; + dup '[ drop [ , run ] call-listener ] { 0 0 } >>align ; : ( -- gadget ) 1 >>fill demo-vocabs [ add-gadget ] each ; From 833c608bec7225020a5a835d39f9d2a31efb027d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Aug 2008 14:23:50 -0500 Subject: [PATCH 08/22] cfdg.models.chiaroscuro: Use new macros --- .../models/chiaroscuro/chiaroscuro.factor | 34 +++++++++---------- 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor index 1034f1527b..d0474cdcb4 100644 --- a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor +++ b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor @@ -5,34 +5,32 @@ USING: kernel namespaces sequences math IN: cfdg.models.chiaroscuro +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DEFER: white -: black ( -- ) iterate? [ - { { 60 [ [ 0.6 s circle ] do - [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] } - { 1 [ white black ] } } - call-random-weighted -] when ; +: black ( -- ) + { + { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] } + { 1 [ white black ] } + } + rules ; -: white ( -- ) iterate? [ - { { 60 [ - [ 0.6 s circle ] do - [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do - ] } - { 1 [ - black white - ] } } - call-random-weighted -] when ; +: white ( -- ) + { + { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] } + { 1 [ black white ] } + } + rules ; -: chiaroscuro ( -- ) [ 0.5 b black ] do ; +: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : init ( -- ) [ -0.5 b ] >background { -3 6 -2 6 } >viewport - 0.01 >threshold + 0.03 >threshold [ chiaroscuro ] >start-shape ; : run ( -- ) [ init ] cfdg-window. ; From ce81ab466a980a633386322339e5d66b2358335f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Aug 2008 14:24:29 -0500 Subject: [PATCH 09/22] lsys.ui: Use color objects --- extra/lsys/ui/ui.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index 420d5a3f4c..d9f4a0f3c0 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -41,7 +41,7 @@ VAR: model : display ( -- ) -black gl-clear +black set-clear-color GL_COLOR_BUFFER_BIT glClear GL_FLAT glShadeModel @@ -57,7 +57,9 @@ camera> do-look-at GL_FRONT_AND_BACK GL_LINE glPolygonMode -white gl-color +! white gl-color + +white set-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd From 50d6d8ac609bae4af40120879e47082697ea59ae Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Aug 2008 14:24:42 -0500 Subject: [PATCH 10/22] Remove 'demos' tag from non-runnable vocabularies --- extra/boolean-expr/tags.txt | 2 +- extra/lisppaste/tags.txt | 1 - extra/log-viewer/tags.txt | 2 +- extra/morse/tags.txt | 2 +- extra/msxml-to-csv/tags.txt | 2 +- extra/roman/tags.txt | 2 +- extra/taxes/tags.txt | 2 +- extra/turing/tags.txt | 2 +- extra/yahoo/tags.txt | 1 - 9 files changed, 7 insertions(+), 9 deletions(-) diff --git a/extra/boolean-expr/tags.txt b/extra/boolean-expr/tags.txt index cb5fc203e1..8b13789179 100644 --- a/extra/boolean-expr/tags.txt +++ b/extra/boolean-expr/tags.txt @@ -1 +1 @@ -demos + diff --git a/extra/lisppaste/tags.txt b/extra/lisppaste/tags.txt index d17547f347..93e65ae758 100644 --- a/extra/lisppaste/tags.txt +++ b/extra/lisppaste/tags.txt @@ -1,3 +1,2 @@ -demos web network diff --git a/extra/log-viewer/tags.txt b/extra/log-viewer/tags.txt index cb5fc203e1..8b13789179 100755 --- a/extra/log-viewer/tags.txt +++ b/extra/log-viewer/tags.txt @@ -1 +1 @@ -demos + diff --git a/extra/morse/tags.txt b/extra/morse/tags.txt index cb5fc203e1..33a9488b16 100644 --- a/extra/morse/tags.txt +++ b/extra/morse/tags.txt @@ -1 +1 @@ -demos +example diff --git a/extra/msxml-to-csv/tags.txt b/extra/msxml-to-csv/tags.txt index cb5fc203e1..8b13789179 100644 --- a/extra/msxml-to-csv/tags.txt +++ b/extra/msxml-to-csv/tags.txt @@ -1 +1 @@ -demos + diff --git a/extra/roman/tags.txt b/extra/roman/tags.txt index cb5fc203e1..8b13789179 100644 --- a/extra/roman/tags.txt +++ b/extra/roman/tags.txt @@ -1 +1 @@ -demos + diff --git a/extra/taxes/tags.txt b/extra/taxes/tags.txt index cb5fc203e1..8b13789179 100644 --- a/extra/taxes/tags.txt +++ b/extra/taxes/tags.txt @@ -1 +1 @@ -demos + diff --git a/extra/turing/tags.txt b/extra/turing/tags.txt index cb5fc203e1..8b13789179 100644 --- a/extra/turing/tags.txt +++ b/extra/turing/tags.txt @@ -1 +1 @@ -demos + diff --git a/extra/yahoo/tags.txt b/extra/yahoo/tags.txt index 2675462a84..c0772185a0 100644 --- a/extra/yahoo/tags.txt +++ b/extra/yahoo/tags.txt @@ -1,2 +1 @@ -demos web From d4bdeab1c76201678b79434ba4b7d171c50ae7d9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Aug 2008 15:14:42 -0500 Subject: [PATCH 11/22] lsys.ui: Minor fix --- extra/lsys/ui/ui.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index d9f4a0f3c0..832f7b9131 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -57,9 +57,9 @@ camera> do-look-at GL_FRONT_AND_BACK GL_LINE glPolygonMode -! white gl-color +white color>raw glColor4d -white set-color +! white set-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd From bbcc4c238418536ac16be369173d4ded33b9a509 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Aug 2008 17:51:01 -0500 Subject: [PATCH 12/22] Builder fixes --- basis/persistent/hashtables/hashtables-tests.factor | 6 ++++++ basis/persistent/sequences/sequences-docs.factor | 6 +++--- basis/persistent/vectors/vectors-docs.factor | 6 +++--- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index accebfd778..ac6aa240cc 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -10,6 +10,10 @@ tools.test kernel namespaces random math.ranges sequences fry ; [ f ] [ "X" PH{ { "A" "B" } } at ] unit-test +! We have to define these first so that they're compiled before +! the below hashtables are parsed... +<< + TUPLE: hash-0-a ; M: hash-0-a hashcode* 2drop 0 ; @@ -18,6 +22,8 @@ TUPLE: hash-0-b ; M: hash-0-b hashcode* 2drop 0 ; +>> + [ ] [ PH{ } "a" T{ hash-0-a } rot new-at diff --git a/basis/persistent/sequences/sequences-docs.factor b/basis/persistent/sequences/sequences-docs.factor index beacf58966..53d15efeec 100644 --- a/basis/persistent/sequences/sequences-docs.factor +++ b/basis/persistent/sequences/sequences-docs.factor @@ -4,14 +4,14 @@ USING: help.markup help.syntax math sequences kernel ; HELP: new-nth { $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } } { $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } -{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; +{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; HELP: ppush { $values { "val" object } { "seq" sequence } { "seq'" sequence } } { $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } -{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; +{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; HELP: ppop { $values { "seq" sequence } { "seq'" sequence } } { $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } -{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; +{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; diff --git a/basis/persistent/vectors/vectors-docs.factor b/basis/persistent/vectors/vectors-docs.factor index f17fca1ded..c49e56d2c5 100644 --- a/basis/persistent/vectors/vectors-docs.factor +++ b/basis/persistent/vectors/vectors-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel math sequences ; -IN: persistent-vectors +IN: persistent.vectors HELP: PV{ { $syntax "elements... }" } @@ -12,7 +12,7 @@ HELP: >persistent-vector HELP: persistent-vector { $class-description "The class of persistent vectors." } ; -ARTICLE: "persistent-vectors" "Persistent vectors" +ARTICLE: "persistent.vectors" "Persistent vectors" "A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time." $nl "The class of persistent vectors:" @@ -31,4 +31,4 @@ $nl $nl "This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ; -ABOUT: "persistent-vectors" +ABOUT: "persistent.vectors" From 52f586877fb56f6c5fb0958d578fd9b1c42c551f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Aug 2008 19:01:17 -0500 Subject: [PATCH 13/22] More data structure cleanups --- basis/disjoint-sets/disjoint-sets.factor | 5 +++-- basis/persistent/hashtables/hashtables.factor | 7 +++++++ .../persistent/sequences/sequences-docs.factor | 18 ++++++++++++------ basis/persistent/vectors/vectors-docs.factor | 6 ------ 4 files changed, 22 insertions(+), 14 deletions(-) diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index a885e333c5..680103f188 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hints kernel locals math hashtables -assocs fry ; - +assocs fry sequences ; IN: disjoint-sets TUPLE: disjoint-set @@ -65,6 +64,8 @@ M: disjoint-set add-atom [ 1 -rot counts>> set-at ] 2tri ; +: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ; + GENERIC: equiv-set-size ( a disjoint-set -- n ) M: disjoint-set equiv-set-size [ representative ] keep count ; diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index a68fa7c365..ae60aba50e 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -41,6 +41,13 @@ M: persistent-hash >alist [ root>> >alist% ] { } make ; : >persistent-hash ( assoc -- phash ) T{ persistent-hash } swap [ spin new-at ] assoc-each ; +M: persistent-hash equal? + over persistent-hash? [ assoc= ] [ 2drop f ] if ; + +M: persistent-hash hashcode* nip assoc-size ; + +M: persistent-hash clone ; + : PH{ \ } [ >persistent-hash ] parse-literal ; parsing M: persistent-hash pprint-delims drop \ PH{ \ } ; diff --git a/basis/persistent/sequences/sequences-docs.factor b/basis/persistent/sequences/sequences-docs.factor index 53d15efeec..986b16c737 100644 --- a/basis/persistent/sequences/sequences-docs.factor +++ b/basis/persistent/sequences/sequences-docs.factor @@ -3,15 +3,21 @@ USING: help.markup help.syntax math sequences kernel ; HELP: new-nth { $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } } -{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } -{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; +{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } ; HELP: ppush { $values { "val" object } { "seq" sequence } { "seq'" sequence } } -{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } -{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; +{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } ; HELP: ppop { $values { "seq" sequence } { "seq'" sequence } } -{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } -{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ; +{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } ; + +ARTICLE: "persistent.sequences" "Persistent sequence protocol" +"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as " { $link length } " and " { $link nth } ", together with the following operations:" +{ $subsection new-nth } +{ $subsection ppush } +{ $subsection ppop } +"The default implementations of the above run in " { $snippet "O(n)" } " time; the " { $vocab-link "persistent.vectors" } " vocabulary provides an implementation of these operations in " { $snippet "O(1)" } " time." ; + +ABOUT: "persistent.sequences" diff --git a/basis/persistent/vectors/vectors-docs.factor b/basis/persistent/vectors/vectors-docs.factor index c49e56d2c5..4816877a35 100644 --- a/basis/persistent/vectors/vectors-docs.factor +++ b/basis/persistent/vectors/vectors-docs.factor @@ -17,12 +17,6 @@ ARTICLE: "persistent.vectors" "Persistent vectors" $nl "The class of persistent vectors:" { $subsection persistent-vector } -"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")." -$nl -"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:" -{ $subsection new-nth } -{ $subsection ppush } -{ $subsection ppop } "Converting a sequence into a persistent vector:" { $subsection >persistent-vector } "Persistent vectors have a literal syntax:" From b26aba48e3693b869e8b56a3fec2470cfcb63581 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Aug 2008 19:04:18 -0500 Subject: [PATCH 14/22] cfdg.models.game1-turn6: Use new macros --- .../models/game1-turn6/game1-turn6.factor | 44 +++++++++++-------- 1 file changed, 25 insertions(+), 19 deletions(-) diff --git a/extra/cfdg/models/game1-turn6/game1-turn6.factor b/extra/cfdg/models/game1-turn6/game1-turn6.factor index 3e0994112a..5e512cd74a 100644 --- a/extra/cfdg/models/game1-turn6/game1-turn6.factor +++ b/extra/cfdg/models/game1-turn6/game1-turn6.factor @@ -6,29 +6,35 @@ IN: cfdg.models.game1-turn6 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: f-triangles ( -- ) iterate? [ -[ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.8 b triangle ] do -[ 10 hue 0.9 sat 0.33 b triangle ] do -[ 0.9 s 10 hue 0.5 sat 1 b triangle ] do -[ 0.8 s 5 r f-triangles ] do -] when ; +: f-triangles ( -- ) + { + [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ] + [ 10 hue 0.9 sat 0.33 b triangle ] + [ 0.9 s 10 hue 0.5 sat 1.00 b triangle ] + [ 0.8 s 5 r f-triangles ] + } + rule ; -: f-squares ( -- ) iterate? [ -[ 0.1 x 0.1 y -0.33 alpha 250 hue 0.7 sat 0.8 b square ] do -[ 220 hue 0.9 sat 0.33 b square ] do -[ 0.9 s 220 hue 0.25 sat 1 b square ] do -[ 0.8 s 5 r f-squares ] do -] when ; +: f-squares ( -- ) + { + [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ] + [ 220 hue 0.90 sat 0.33 b square ] + [ 0.9 s 220 hue 0.25 sat 1.00 b square ] + [ 0.8 s 5 r f-squares ] + } + rule ; DEFER: start -: spiral ( -- ) iterate? [ - { { 1 [ f-squares - [ 0.5 x 0.5 y 45 r f-triangles ] do - [ 1 y 25 r 0.9 s spiral ] do ] } - { 0.022 [ [ 90 flip 50 hue start ] do ] } } - call-random-weighted -] when ; +: spiral ( -- ) + { + { 1 [ f-squares ] + [ 0.5 x 0.5 y 45 r f-triangles ] + [ 1 y 25 r 0.9 s spiral ] } + + { 0.022 [ 90 flip 50 hue start ] } + } + rules ; : start ( -- ) [ spiral ] do From 8aef8fda256199626a534946ef1bf3db4f9e7148 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Aug 2008 19:12:57 -0500 Subject: [PATCH 15/22] cfdg.models.spirales: Use new macros --- extra/cfdg/models/spirales/spirales.factor | 28 ++++++---------------- 1 file changed, 7 insertions(+), 21 deletions(-) diff --git a/extra/cfdg/models/spirales/spirales.factor b/extra/cfdg/models/spirales/spirales.factor index 985c21643e..f804b6ba83 100644 --- a/extra/cfdg/models/spirales/spirales.factor +++ b/extra/cfdg/models/spirales/spirales.factor @@ -7,33 +7,19 @@ DEFER: line ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: block ( -- ) - [ - [ circle ] do - [ 0.3 s 60 flip line ] do - ] - recursive ; +: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ; -: a1 ( -- ) - [ - [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do - [ block ] do - ] - recursive ; +: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ; -: line ( -- ) - -0.3 a - [ 0 rotate a1 ] do - [ 120 rotate a1 ] do - [ 240 rotate a1 ] do ; +: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : init ( -- ) - [ -1 b ] >background - { -20 40 -20 40 } viewport set - [ line ] >start-shape - 0.03 >threshold ; + [ -1 b ] >background + { -20 40 -20 40 } >viewport + [ line ] >start-shape + 0.04 >threshold ; : run ( -- ) [ init ] cfdg-window. ; From c6b310228eaf94e311ce80af1310b2d8cfcfb0bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Aug 2008 01:08:11 -0500 Subject: [PATCH 16/22] Finishing up with propagation and escape analysis --- .../tree/cleanup/cleanup-tests.factor | 3 +- .../tree/copy-equiv/copy-equiv.factor | 20 ++-- .../allocations/allocations.factor | 16 ++- .../escape-analysis-tests.factor | 100 +++++++++++++++++- .../escape-analysis/escape-analysis.factor | 1 - .../recursive/recursive.factor | 34 +++--- .../tree/normalization/normalization.factor | 4 + .../compiler/tree/optimizer/optimizer.factor | 1 - .../tree/propagation/branches/branches.factor | 36 +++++-- .../tree/propagation/info/info.factor | 25 ++++- .../tree/propagation/inlining/inlining.factor | 3 +- .../tree/propagation/nodes/nodes.factor | 4 +- .../tree/propagation/propagation-tests.factor | 13 ++- .../tree/propagation/propagation.factor | 10 +- .../propagation/recursive/recursive.factor | 31 +++--- .../stack-checker/inlining/inlining.factor | 7 +- 16 files changed, 232 insertions(+), 76 deletions(-) diff --git a/unfinished/compiler/tree/cleanup/cleanup-tests.factor b/unfinished/compiler/tree/cleanup/cleanup-tests.factor index c483b8bdc6..4d2b312e9c 100644 --- a/unfinished/compiler/tree/cleanup/cleanup-tests.factor +++ b/unfinished/compiler/tree/cleanup/cleanup-tests.factor @@ -9,12 +9,11 @@ compiler.tree compiler.tree.combinators compiler.tree.cleanup compiler.tree.builder -compiler.tree.copy-equiv compiler.tree.normalization compiler.tree.propagation ; : cleaned-up-tree ( quot -- nodes ) - build-tree normalize compute-copy-equiv propagate cleanup ; + build-tree normalize propagate cleanup ; [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor index a96fe8eb22..6a4cca7ff4 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor +++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor @@ -7,6 +7,9 @@ compiler.tree.def-use compiler.tree.combinators ; IN: compiler.tree.copy-equiv +! This is not really a compiler pass; its invoked as part of +! propagation. + ! Two values are copy-equivalent if they are always identical ! at run-time ("DS" relation). This is just a weak form of ! value numbering. @@ -26,8 +29,7 @@ SYMBOL: copies ] if ] ; -: resolve-copy ( copy -- val ) - copies get compress-path [ "Unknown value" throw ] unless* ; +: resolve-copy ( copy -- val ) copies get compress-path ; : is-copy-of ( val copy -- ) copies get set-at ; @@ -68,13 +70,7 @@ M: #phi compute-copy-equiv* M: node compute-copy-equiv* drop ; -: amend-copy-equiv ( node -- ) - [ - [ node-defs-values [ introduce-value ] each ] - [ compute-copy-equiv* ] - bi - ] each-node ; - -: compute-copy-equiv ( node -- node ) - H{ } clone copies set - dup amend-copy-equiv ; +: compute-copy-equiv ( node -- ) + [ node-defs-values [ introduce-value ] each ] + [ compute-copy-equiv* ] + bi ; diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor index b4f4a2a5dd..8bcaf53ab1 100644 --- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor @@ -28,14 +28,9 @@ C: slot-access : record-allocation ( allocation value -- ) (allocation) set-at ; -: unknown-allocation ( value -- ) t swap record-allocation ; - : record-allocations ( allocations values -- ) [ record-allocation ] 2each ; -: unknown-allocations ( values -- ) - [ unknown-allocation ] each ; - ! We track escaping values with a disjoint set. SYMBOL: escaping-values @@ -66,10 +61,21 @@ SYMBOL: +escaping+ : merge-slots ( values -- value ) [ merge-values ] keep ; +: add-escaping-value ( value -- ) + +escaping+ escaping-values get equate ; + : add-escaping-values ( values -- ) escaping-values get '[ +escaping+ , equate ] each ; +: unknown-allocation ( value -- ) + [ add-escaping-value ] + [ t swap record-allocation ] + bi ; + +: unknown-allocations ( values -- ) + [ unknown-allocation ] each ; + : escaping-value? ( value -- ? ) +escaping+ escaping-values get equiv? ; diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor index 256152a556..2728a3c933 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -12,7 +12,7 @@ prettyprint classes.tuple.private classes classes.tuple ; GENERIC: count-unboxed-allocations* ( m node -- n ) : (count-unboxed-allocations) ( m node -- n ) - out-d>> first escaping-allocation? [ 1+ ] unless ; + dup out-d>> first escaping-allocation? [ drop ] [ short. 1+ ] if ; M: #call count-unboxed-allocations* dup word>> \ = @@ -27,10 +27,8 @@ M: node count-unboxed-allocations* drop ; : count-unboxed-allocations ( quot -- sizes ) build-tree normalize - compute-copy-equiv propagate cleanup - compute-copy-equiv escape-analysis 0 swap [ count-unboxed-allocations* ] each-node ; @@ -187,3 +185,99 @@ TUPLE: cons { car read-only } { cdr read-only } ; 1 2 cons boa infinite-cons-loop ] count-unboxed-allocations ] unit-test + +TUPLE: rw-box i ; + +C: rw-box + +[ 0 ] [ [ i>> ] count-unboxed-allocations ] unit-test + +: fake-fib ( m -- n ) + dup i>> 1 <= [ drop 1 ] when ; inline recursive + +[ 0 ] [ [ fake-fib i>> ] count-unboxed-allocations ] unit-test + +TUPLE: ro-box { i read-only } ; + +C: ro-box + +: tuple-fib ( m -- n ) + dup i>> 1 <= [ + drop 1 + ] [ + i>> 1- + dup tuple-fib + swap + i>> 1- + tuple-fib + swap i>> swap i>> + + ] if ; inline recursive + +[ 5 ] [ [ tuple-fib i>> ] count-unboxed-allocations ] unit-test + +[ 3 ] [ [ tuple-fib ] count-unboxed-allocations ] unit-test + +: bad-tuple-fib-1 ( m -- n ) + dup i>> 1 <= [ + drop 1 + ] [ + i>> 1- + dup bad-tuple-fib-1 + swap + i>> 1- + bad-tuple-fib-1 dup . + swap i>> swap i>> + + ] if ; inline recursive + +[ 3 ] [ [ bad-tuple-fib-1 i>> ] count-unboxed-allocations ] unit-test + +: bad-tuple-fib-2 ( m -- n ) + dup . + dup i>> 1 <= [ + drop 1 + ] [ + i>> 1- + dup bad-tuple-fib-2 + swap + i>> 1- + bad-tuple-fib-2 + swap i>> swap i>> + + ] if ; inline recursive + +[ 2 ] [ [ bad-tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test + +: tuple-fib-2 ( m -- n ) + dup 1 <= [ + drop 1 + ] [ + 1- dup tuple-fib-2 + swap + 1- tuple-fib-2 + swap i>> swap i>> + + ] if ; inline recursive + +[ 2 ] [ [ tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test + +: tuple-fib-3 ( m -- n ) + dup 1 <= [ + drop 1 + ] [ + 1- dup tuple-fib-3 + swap + 1- tuple-fib-3 dup . + swap i>> swap i>> + + ] if ; inline recursive + +[ 0 ] [ [ tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test + +: bad-tuple-fib-3 ( m -- n ) + dup 1 <= [ + drop 1 + ] [ + 1- dup bad-tuple-fib-3 + swap + 1- bad-tuple-fib-3 + 2drop f + ] if ; inline recursive + +[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor index 0ba44a1dc5..d1b1ab2dd0 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor @@ -4,7 +4,6 @@ USING: kernel namespaces search-dequeues assocs fry sequences disjoint-sets compiler.tree compiler.tree.def-use -compiler.tree.copy-equiv compiler.tree.escape-analysis.allocations compiler.tree.escape-analysis.recursive compiler.tree.escape-analysis.branches diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor index 5bc386690d..e72f4b6a45 100644 --- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor +++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences math combinators accessors namespaces +fry disjoint-sets compiler.tree -compiler.tree.copy-equiv compiler.tree.combinators compiler.tree.escape-analysis.nodes compiler.tree.escape-analysis.branches @@ -17,9 +17,10 @@ IN: compiler.tree.escape-analysis.recursive [ [ [ allocation ] bi@ congruent? ] 2all? ] } cond ; -: check-fixed-point ( node alloc1 alloc2 -- node ) - [ congruent? ] 2all? - [ dup label>> f >>fixed-point drop ] unless ; inline +: check-fixed-point ( node alloc1 alloc2 -- ) + [ congruent? ] 2all? [ drop ] [ + label>> f >>fixed-point drop + ] if ; : node-input-allocations ( node -- allocations ) in-d>> [ allocation ] map ; @@ -35,31 +36,26 @@ IN: compiler.tree.escape-analysis.recursive [ [ merge-values ] 2each ] [ [ (merge-allocations) ] dip - [ [ allocation ] map check-fixed-point drop ] + [ [ allocation ] map check-fixed-point ] [ record-allocations ] 2bi ] 2bi ; M: #recursive escape-analysis* ( #recursive -- ) [ - ! copies [ clone ] change - child>> [ first analyze-recursive-phi ] [ (escape-analysis) ] bi ] until-fixed-point ; -M: #call-recursive escape-analysis* ( #call-label -- ) - dup - [ node-output-allocations ] - [ label>> return>> node-input-allocations ] bi - [ check-fixed-point ] keep - swap out-d>> record-allocations ; +: return-allocations ( node -- allocations ) + label>> return>> node-input-allocations ; -! M: #return-recursive escape-analysis* ( #return-recursive -- ) -! dup dup label>> calls>> dup empty? [ 3drop ] [ -! [ node-input-allocations ] -! [ first node-output-allocations ] bi* -! check-fixed-point drop -! ] if ; +M: #call-recursive escape-analysis* ( #call-label -- ) + [ ] [ return-allocations ] [ node-output-allocations ] tri + [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ; + +M: #return-recursive escape-analysis* ( #return-recursive -- ) + [ in-d>> ] [ label>> calls>> ] bi + [ out-d>> escaping-values get '[ , equate ] 2each ] with each ; diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor index b6a9f126d6..4eb28be917 100644 --- a/unfinished/compiler/tree/normalization/normalization.factor +++ b/unfinished/compiler/tree/normalization/normalization.factor @@ -128,6 +128,10 @@ M: #recursive normalize* dup dup label>> introductions>> eliminate-recursive-introductions ; +M: #enter-recursive normalize* + dup [ label>> ] keep >>enter-recursive drop + dup [ label>> ] [ out-d>> ] bi >>enter-out drop ; + : unchanged-underneath ( #call-recursive -- n ) [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ; diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor index 753c962061..f28b192d2b 100644 --- a/unfinished/compiler/tree/optimizer/optimizer.factor +++ b/unfinished/compiler/tree/optimizer/optimizer.factor @@ -9,7 +9,6 @@ IN: compiler.tree.optimizer : optimize-tree ( nodes -- nodes' ) normalize - compute-copy-equiv propagate cleanup compute-def-use diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index eb6ba3697f..00a7833655 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -90,7 +90,7 @@ M: #phi propagate-before ( #phi -- ) [ drop condition-value get [ [ =t ] [ =t ] bi* <--> ] - [ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume + [ [ =f ] [ =f ] bi* <--> ] 2bi /\ ] } { @@ -98,19 +98,43 @@ M: #phi propagate-before ( #phi -- ) [ drop condition-value get [ [ =t ] [ =f ] bi* <--> ] - [ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume + [ [ =f ] [ =t ] bi* <--> ] 2bi /\ ] } { { { t f } { f } } - [ first =t condition-value get =t /\ swap t--> assume ] + [ + first =t + condition-value get =t /\ + swap t--> + ] } { { { f } { t f } } - [ second =t condition-value get =f /\ swap t--> assume ] + [ + second =t + condition-value get =f /\ + swap t--> + ] } - [ 3drop ] - } case ; + ! { + ! { { t f } { } } + ! [ B + ! first + ! [ [ =t ] bi@ <--> ] + ! [ [ =f ] bi@ <--> ] 2bi /\ + ! ] + ! } + ! { + ! { { } { t f } } + ! [ + ! second + ! [ [ =t ] bi@ <--> ] + ! [ [ =f ] bi@ <--> ] 2bi /\ + ! ] + ! } + [ 3drop f ] + } case assume ; M: #phi propagate-after ( #phi -- ) condition-value get [ diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 3d79840f7e..bc6f1d73e3 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra kernel accessors math math.intervals namespaces sequences words -combinators arrays compiler.tree.copy-equiv ; +combinators combinators.short-circuit arrays +compiler.tree.copy-equiv ; IN: compiler.tree.propagation.info : false-class? ( class -- ? ) \ f class<= ; @@ -218,6 +219,28 @@ DEFER: (value-info-union) [ drop null-info ] [ dup first [ value-info-union ] reduce ] if ; +: literals<= ( info1 info2 -- ? ) + { + { [ dup literal?>> not ] [ 2drop t ] } + { [ over literal?>> not ] [ 2drop f ] } + [ [ literal>> ] bi@ eql? ] + } cond ; + +: value-info<= ( info1 info2 -- ? ) + { + { [ dup not ] [ 2drop t ] } + { [ over not ] [ 2drop f ] } + [ + { + [ [ class>> ] bi@ class<= ] + [ [ interval>> ] bi@ interval-subset? ] + [ literals<= ] + [ [ length>> ] bi@ value-info<= ] + [ [ slots>> ] bi@ [ value-info<= ] 2all? ] + } 2&& + ] + } cond ; + ! Current value --> info mapping SYMBOL: value-infos diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor index e4da863d68..22e056ce60 100644 --- a/unfinished/compiler/tree/propagation/inlining/inlining.factor +++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor @@ -6,7 +6,6 @@ classes.union sets quotations assocs combinators words namespaces compiler.tree compiler.tree.builder -compiler.tree.copy-equiv compiler.tree.normalization compiler.tree.propagation.info compiler.tree.propagation.nodes ; @@ -25,7 +24,7 @@ M: quotation splicing-nodes normalize ; : propagate-body ( #call -- ) - body>> [ amend-copy-equiv ] [ (propagate) ] bi ; + body>> (propagate) ; ! Dispatch elimination : eliminate-dispatch ( #call word/quot/f -- ? ) diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor index 6317ec4e06..10dd1a03c6 100644 --- a/unfinished/compiler/tree/propagation/nodes/nodes.factor +++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor @@ -3,6 +3,7 @@ USING: sequences accessors kernel assocs sequences compiler.tree compiler.tree.def-use +compiler.tree.copy-equiv compiler.tree.propagation.info ; IN: compiler.tree.propagation.nodes @@ -15,7 +16,8 @@ GENERIC: propagate-after ( node -- ) GENERIC: propagate-around ( node -- ) -: (propagate) ( node -- ) [ propagate-around ] each ; +: (propagate) ( node -- ) + [ [ compute-copy-equiv ] [ propagate-around ] bi ] each ; : extract-value-info ( values -- assoc ) [ dup value-info ] H{ } map>assoc ; diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 515d1bf474..d2583af832 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -1,5 +1,5 @@ USING: kernel compiler.tree.builder compiler.tree -compiler.tree.propagation compiler.tree.copy-equiv +compiler.tree.propagation compiler.tree.normalization tools.test math math.order accessors sequences arrays kernel.private vectors alien.accessors alien.c-types sequences.private @@ -14,7 +14,6 @@ IN: compiler.tree.propagation.tests : final-info ( quot -- seq ) build-tree normalize - compute-copy-equiv propagate peek node-input-infos ; @@ -145,6 +144,8 @@ IN: compiler.tree.propagation.tests [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ] unit-test +[ f ] [ [ t xor ] final-classes first null-class? ] unit-test + [ t ] [ [ t or ] final-classes first true-class? ] unit-test [ t ] [ [ t swap or ] final-classes first true-class? ] unit-test @@ -155,12 +156,20 @@ IN: compiler.tree.propagation.tests [ t ] [ [ dup not or ] final-classes first true-class? ] unit-test +[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test + [ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test +[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test + [ t ] [ [ dup not and ] final-classes first false-class? ] unit-test +[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test + [ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test +[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test + [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test [ V{ fixnum } ] [ diff --git a/unfinished/compiler/tree/propagation/propagation.factor b/unfinished/compiler/tree/propagation/propagation.factor index db69024413..7fa971bafe 100755 --- a/unfinished/compiler/tree/propagation/propagation.factor +++ b/unfinished/compiler/tree/propagation/propagation.factor @@ -3,6 +3,7 @@ USING: accessors kernel sequences namespaces hashtables compiler.tree compiler.tree.def-use +compiler.tree.copy-equiv compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.simple @@ -13,8 +14,7 @@ compiler.tree.propagation.known-words ; IN: compiler.tree.propagation : propagate ( node -- node ) - [ - H{ } clone constraints set - H{ } clone value-infos set - dup (propagate) - ] with-scope ; + H{ } clone copies set + H{ } clone constraints set + H{ } clone value-infos set + dup (propagate) ; diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 3732d7c08c..9e1bf52bbf 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -13,8 +13,9 @@ compiler.tree.propagation.branches compiler.tree.propagation.constraints ; IN: compiler.tree.propagation.recursive -: check-fixed-point ( node infos1 infos2 -- node ) - sequence= [ dup label>> f >>fixed-point drop ] unless ; inline +: check-fixed-point ( node infos1 infos2 -- ) + [ value-info<= ] 2all? + [ drop ] [ label>> f >>fixed-point drop ] if ; : recursive-stacks ( #enter-recursive -- stacks initial ) [ label>> calls>> [ node-input-infos ] map flip ] @@ -46,19 +47,21 @@ IN: compiler.tree.propagation.recursive : propagate-recursive-phi ( #enter-recursive -- ) [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri - [ node-output-infos check-fixed-point drop ] 2keep - out-d>> set-value-infos ; + [ node-output-infos check-fixed-point ] + [ out-d>> set-value-infos drop ] + 3bi ; M: #recursive propagate-around ( #recursive -- ) - [ - copies [ clone ] change + { 0 } clone [ USE: math + dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if constraints [ clone ] change child>> + [ first compute-copy-equiv ] [ first propagate-recursive-phi ] [ (propagate) ] - bi - ] until-fixed-point ; + tri + ] curry until-fixed-point ; : generalize-return-interval ( info -- info' ) dup [ literal?>> ] [ class>> null-class? ] bi or @@ -67,11 +70,9 @@ M: #recursive propagate-around ( #recursive -- ) : generalize-return ( infos -- infos' ) [ generalize-return-interval ] map ; -M: #call-recursive propagate-before ( #call-label -- ) - dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi - [ check-fixed-point ] keep - generalize-return swap out-d>> set-value-infos ; +: return-infos ( node -- infos ) + label>> return>> node-input-infos generalize-return ; -M: #return-recursive propagate-before ( #return-recursive -- ) - dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi - check-fixed-point drop ; +M: #call-recursive propagate-before ( #call-label -- ) + [ ] [ return-infos ] [ node-output-infos ] tri + [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ; diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor index ffa90c13ed..155baa7e65 100644 --- a/unfinished/stack-checker/inlining/inlining.factor +++ b/unfinished/stack-checker/inlining/inlining.factor @@ -17,7 +17,12 @@ IN: stack-checker.inlining : (inline-word) ( word label -- ) [ [ def>> ] keep ] dip infer-quot-recursive ; -TUPLE: inline-recursive word enter-out return calls fixed-point introductions ; +TUPLE: inline-recursive +word +enter-out enter-recursive +return calls +fixed-point +introductions ; : ( word -- label ) inline-recursive new swap >>word ; From f5ea3ccbbed2354f9f537b0fa4c1f40aa6d85e46 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Thu, 7 Aug 2008 01:58:50 -0500 Subject: [PATCH 17/22] minor fixes --- extra/24-game/24-game.factor | 56 +++++++++++++++++++++++++----------- extra/24-game/tags.txt | 1 + 2 files changed, 41 insertions(+), 16 deletions(-) diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 569cef8302..52f0cd6833 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -3,36 +3,60 @@ USING: kernel random namespaces shuffle sequences parser io math prettyprint combinators continuations -vectors words quotations accessors math.parser -backtrack math.ranges locals fry memoize macros assocs ; +arrays words quotations accessors math.parser backtrack assocs ; IN: 24-game - +SYMBOL: commands : nop ; : do-something ( a b -- c ) { + - * } amb-execute ; : maybe-swap ( a b -- a b ) { nop swap } amb-execute ; : some-rots ( a b c -- a b c ) #! Try each permutation of 3 elements. { nop rot -rot swap spin swapd } amb-execute ; -: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ; -: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ; +: makes-24? ( a b c d -- ? ) + [ + 2 [ some-rots do-something ] times + maybe-swap do-something + 24 = + ] + [ 4drop ] + if-amb ; : q ( -- obj ) "quit" ; -: show-commands ( -- ) "Commands: " write "commands" get unparse print ; +: show-commands ( -- ) "Commands: " write commands get unparse print ; : report ( vector -- ) unparse print show-commands ; : give-help ( -- ) "Command not found..." print show-commands ; : find-word ( string choices -- word ) [ name>> = ] with find nip ; -: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ; +: obtain-word ( -- word ) + readln commands get find-word dup + [ drop give-help obtain-word ] unless ; : done? ( vector -- t/f ) 1 swap length = ; -: victory? ( vector -- t/f ) V{ 24 } = ; -: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ; -: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ; +: victory? ( vector -- t/f ) { 24 } = ; +: apply-word ( vector word -- array ) 1quotation with-datastack >array ; +: update-commands ( vector -- ) + length 3 < + [ commands [ \ rot swap remove ] change ] + [ ] + if ; DEFER: check-status : quit-game ( vector -- ) drop "you're a quitter" print ; : quit? ( vector -- t/f ) peek "quit" = ; -: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ; -: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status ; -: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ; -: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ; -: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ; -: set-commands ( -- ) { + - * / rot swap q } "commands" set ; +: end-game ( vector -- ) + dup victory? + [ drop "You WON!" ] + [ pop number>string " is not 24... You lose." append ] + if print ; + +! The following two words are mutually recursive, +! providing the repl loop of the game +: repeat ( vector -- ) + dup report obtain-word apply-word dup update-commands check-status ; +: check-status ( object -- ) + dup done? + [ end-game ] + [ dup quit? [ quit-game ] [ repeat ] if ] + if ; +: build-quad ( -- array ) 4 [ 10 random ] replicate >array ; +: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ; +: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ; +: set-commands ( -- ) { + - * / rot swap q } commands set ; : play-game ( -- ) set-commands 24-able repeat ; \ No newline at end of file diff --git a/extra/24-game/tags.txt b/extra/24-game/tags.txt index cb5fc203e1..d2f0464fdb 100644 --- a/extra/24-game/tags.txt +++ b/extra/24-game/tags.txt @@ -1 +1,2 @@ demos +games \ No newline at end of file From f9900202c8f3764adf66abf78446c2a10ea15dea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Aug 2008 06:34:28 -0500 Subject: [PATCH 18/22] Working on tuple unboxing --- .../allocations/allocations.factor | 50 ++++++-- .../escape-analysis-tests.factor | 10 +- .../escape-analysis/escape-analysis.factor | 2 + .../tree/escape-analysis/nodes/nodes.factor | 14 ++- .../recursive/recursive-tests.factor | 1 - .../tree/escape-analysis/simple/simple.factor | 65 ++++++++--- .../compiler/tree/optimizer/optimizer.factor | 17 ++- .../constraints/constraints.factor | 5 +- .../copy/copy-tests.factor} | 4 +- .../copy/copy.factor} | 21 +--- .../tree/propagation/info/info.factor | 2 +- .../tree/propagation/nodes/nodes.factor | 2 +- .../tree/propagation/propagation.factor | 4 +- .../propagation/recursive/recursive.factor | 2 +- unfinished/compiler/tree/tree.factor | 20 +++- .../tree/tuple-unboxing/tuple-unboxing.factor | 109 ++++++++++++++++++ .../tree/untupling/untupling-tests.factor | 50 -------- .../compiler/tree/untupling/untupling.factor | 59 ---------- 18 files changed, 250 insertions(+), 187 deletions(-) rename unfinished/compiler/tree/{copy-equiv/copy-equiv-tests.factor => propagation/copy/copy-tests.factor} (84%) rename unfinished/compiler/tree/{copy-equiv/copy-equiv.factor => propagation/copy/copy.factor} (76%) create mode 100644 unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor delete mode 100644 unfinished/compiler/tree/untupling/untupling-tests.factor delete mode 100644 unfinished/compiler/tree/untupling/untupling.factor diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor index 8bcaf53ab1..973720c388 100644 --- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces sequences kernel math -combinators sets disjoint-sets fry stack-checker.state -compiler.tree.copy-equiv ; +combinators sets disjoint-sets fry stack-checker.state ; IN: compiler.tree.escape-analysis.allocations ! A map from values to one of the following: @@ -18,7 +17,7 @@ TUPLE: slot-access slot# value ; C: slot-access : (allocation) ( value -- value' allocations ) - resolve-copy allocations get ; inline + allocations get ; inline : allocation ( value -- allocation ) (allocation) at dup slot-access? [ @@ -26,7 +25,8 @@ C: slot-access allocation ] when ; -: record-allocation ( allocation value -- ) (allocation) set-at ; +: record-allocation ( allocation value -- ) + (allocation) set-at ; : record-allocations ( allocations values -- ) [ record-allocation ] 2each ; @@ -40,15 +40,16 @@ SYMBOL: +escaping+ +escaping+ over add-atom ; : init-escaping-values ( -- ) - copies get assoc>disjoint-set +escaping+ over add-atom - escaping-values set ; + escaping-values set ; + +: introduce-value ( values -- ) + escaping-values get add-atom ; + +: introduce-values ( values -- ) + escaping-values get add-atoms ; : ( -- value ) - - [ introduce-value ] - [ escaping-values get add-atom ] - [ ] - tri ; + dup escaping-values get add-atom ; : record-slot-access ( out slot# in -- ) over zero? [ 3drop ] [ @@ -61,8 +62,11 @@ SYMBOL: +escaping+ : merge-slots ( values -- value ) [ merge-values ] keep ; +: equate-values ( value1 value2 -- ) + escaping-values get equate ; + : add-escaping-value ( value -- ) - +escaping+ escaping-values get equate ; + +escaping+ equate-values ; : add-escaping-values ( values -- ) escaping-values get @@ -79,6 +83,20 @@ SYMBOL: +escaping+ : escaping-value? ( value -- ? ) +escaping+ escaping-values get equiv? ; +DEFER: copy-value + +: copy-allocation ( allocation -- allocation' ) + { + { [ dup not ] [ ] } + { [ dup t eq? ] [ ] } + [ [ [ introduce-value ] [ copy-value ] [ ] tri ] map ] + } cond ; + +: copy-value ( from to -- ) + [ equate-values ] + [ [ allocation copy-allocation ] dip record-allocation ] + 2bi ; + SYMBOL: escaping-allocations : compute-escaping-allocations ( -- ) @@ -88,3 +106,11 @@ SYMBOL: escaping-allocations : escaping-allocation? ( value -- ? ) escaping-allocations get key? ; + +: unboxed-allocation ( value -- allocation/f ) + dup escaping-allocation? [ drop f ] [ allocation ] if ; + +: unboxed-slot-access? ( value -- ? ) + (allocation) at dup slot-access? + [ value>> unboxed-allocation >boolean ] [ drop f ] if ; + diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor index 2728a3c933..f01949d422 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -1,9 +1,9 @@ IN: compiler.tree.escape-analysis.tests USING: compiler.tree.escape-analysis compiler.tree.escape-analysis.allocations compiler.tree.builder -compiler.tree.normalization compiler.tree.copy-equiv +compiler.tree.normalization math.functions compiler.tree.propagation compiler.tree.cleanup -compiler.tree.combinators compiler.tree sequences math +compiler.tree.combinators compiler.tree sequences math math.private kernel tools.test accessors slots.private quotations.private prettyprint classes.tuple.private classes classes.tuple ; @@ -12,10 +12,10 @@ prettyprint classes.tuple.private classes classes.tuple ; GENERIC: count-unboxed-allocations* ( m node -- n ) : (count-unboxed-allocations) ( m node -- n ) - dup out-d>> first escaping-allocation? [ drop ] [ short. 1+ ] if ; + out-d>> first escaping-allocation? [ 1+ ] unless ; M: #call count-unboxed-allocations* - dup word>> \ = + dup word>> { } memq? [ (count-unboxed-allocations) ] [ drop ] if ; M: #push count-unboxed-allocations* @@ -281,3 +281,5 @@ C: ro-box ] if ; inline recursive [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test + +[ 1 ] [ [ >rect ] count-unboxed-allocations ] unit-test diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor index d1b1ab2dd0..5847f0a5e4 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor @@ -11,6 +11,8 @@ compiler.tree.escape-analysis.nodes compiler.tree.escape-analysis.simple ; IN: compiler.tree.escape-analysis +! This pass must run after propagation + : escape-analysis ( node -- node ) init-escaping-values H{ } clone allocations set diff --git a/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor b/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor index eb56a9e338..3fdde22bd8 100644 --- a/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor +++ b/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor @@ -1,10 +1,16 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences compiler.tree ; +USING: kernel sequences +compiler.tree +compiler.tree.def-use +compiler.tree.escape-analysis.allocations ; IN: compiler.tree.escape-analysis.nodes GENERIC: escape-analysis* ( node -- ) -M: node escape-analysis* drop ; - -: (escape-analysis) ( node -- ) [ escape-analysis* ] each ; +: (escape-analysis) ( node -- ) + [ + [ node-defs-values introduce-values ] + [ escape-analysis* ] + bi + ] each ; diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor index 89ff2e59b4..1f6f347ded 100644 --- a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor +++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor @@ -1,6 +1,5 @@ IN: compiler.tree.escape-analysis.recursive.tests USING: kernel tools.test namespaces sequences -compiler.tree.copy-equiv compiler.tree.escape-analysis.recursive compiler.tree.escape-analysis.allocations ; diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor index 51d3b6913a..22daa36644 100644 --- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor +++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor @@ -1,26 +1,43 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences classes.tuple -classes.tuple.private math math.private slots.private +classes.tuple.private arrays math math.private slots.private combinators dequeues search-dequeues namespaces fry classes -stack-checker.state +classes.algebra stack-checker.state compiler.tree compiler.tree.propagation.info compiler.tree.escape-analysis.nodes compiler.tree.escape-analysis.allocations ; IN: compiler.tree.escape-analysis.simple -M: #introduce escape-analysis* - value>> unknown-allocation ; +M: #declare escape-analysis* drop ; + +M: #terminate escape-analysis* drop ; + +M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ; + +M: #introduce escape-analysis* value>> unknown-allocation ; + +DEFER: record-literal-allocation + +: make-literal-slots ( seq -- values ) + [ [ swap record-literal-allocation ] keep ] map ; + +: record-literal-tuple-allocation ( value object -- ) + tuple-slots rest-slice + make-literal-slots + swap record-allocation ; + +: record-literal-complex-allocation ( value object -- ) + [ real-part ] [ imaginary-part ] bi 2array make-literal-slots + swap record-allocation ; : record-literal-allocation ( value object -- ) - dup class immutable-tuple-class? [ - tuple-slots rest-slice - [ [ swap record-literal-allocation ] keep ] map - swap record-allocation - ] [ - drop unknown-allocation - ] if ; + { + { [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] } + { [ dup complex? ] [ record-literal-complex-allocation ] } + [ drop unknown-allocation ] + } cond ; M: #push escape-analysis* #! Delegation. @@ -34,19 +51,29 @@ M: #push escape-analysis* record-allocation ] [ out-d>> unknown-allocations ] if ; +: record-complex-allocation ( #call -- ) + [ in-d>> ] [ out-d>> first ] bi record-allocation ; + +: slot-offset ( #call -- n/f ) + dup in-d>> + [ first node-value-info class>> ] + [ second node-value-info literal>> ] 2bi + dup fixnum? [ + { + { [ over tuple class<= ] [ 3 - ] } + { [ over complex class<= ] [ 1 - ] } + [ drop f ] + } cond nip + ] [ 2drop f ] if ; + : record-slot-call ( #call -- ) - [ out-d>> first ] - [ dup in-d>> second node-value-info literal>> ] - [ in-d>> first ] tri - over fixnum? [ - [ 3 - ] dip record-slot-access - ] [ - 2drop unknown-allocation - ] if ; + [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri + over [ record-slot-access ] [ 2drop unknown-allocation ] if ; M: #call escape-analysis* dup word>> { { \ [ record-tuple-allocation ] } + { \ [ record-complex-allocation ] } { \ slot [ record-slot-call ] } [ drop diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor index f28b192d2b..e44cf44db7 100644 --- a/unfinished/compiler/tree/optimizer/optimizer.factor +++ b/unfinished/compiler/tree/optimizer/optimizer.factor @@ -1,17 +1,22 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.tree.normalization compiler.tree.copy-equiv -compiler.tree.propagation compiler.tree.cleanup -compiler.tree.def-use compiler.tree.untupling -compiler.tree.dead-code compiler.tree.strength-reduction -compiler.tree.loop-detection compiler.tree.branch-fusion ; +USING: compiler.tree.normalization +compiler.tree.propagation +compiler.tree.cleanup +compiler.tree.escape-analysis +compiler.tree.tuple-unboxing +compiler.tree.def-use +compiler.tree.dead-code +compiler.tree.strength-reduction +compiler.tree.loop-detection +compiler.tree.branch-fusion ; IN: compiler.tree.optimizer : optimize-tree ( nodes -- nodes' ) normalize propagate cleanup - compute-def-use + escape-analysis unbox-tuples compute-def-use remove-dead-code diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor index 46a9fc91ff..cfdf7f5169 100644 --- a/unfinished/compiler/tree/propagation/constraints/constraints.factor +++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor @@ -3,8 +3,9 @@ USING: arrays assocs math math.intervals kernel accessors sequences namespaces classes classes.algebra combinators words -compiler.tree compiler.tree.propagation.info -compiler.tree.copy-equiv ; +compiler.tree +compiler.tree.propagation.info +compiler.tree.propagation.copy ; IN: compiler.tree.propagation.constraints ! A constraint is a statement about a value. diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor b/unfinished/compiler/tree/propagation/copy/copy-tests.factor similarity index 84% rename from unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor rename to unfinished/compiler/tree/propagation/copy/copy-tests.factor index 251c4d40d2..a99c2a2447 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor +++ b/unfinished/compiler/tree/propagation/copy/copy-tests.factor @@ -1,5 +1,5 @@ -IN: compiler.tree.copy-equiv.tests -USING: compiler.tree.copy-equiv tools.test namespaces kernel +IN: compiler.tree.propagation.copy.tests +USING: compiler.tree.propagation.copy tools.test namespaces kernel assocs ; H{ } clone copies set diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/propagation/copy/copy.factor similarity index 76% rename from unfinished/compiler/tree/copy-equiv/copy-equiv.factor rename to unfinished/compiler/tree/propagation/copy/copy.factor index 6a4cca7ff4..ee2d6e7415 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor +++ b/unfinished/compiler/tree/propagation/copy/copy.factor @@ -5,10 +5,7 @@ combinators sets locals compiler.tree compiler.tree.def-use compiler.tree.combinators ; -IN: compiler.tree.copy-equiv - -! This is not really a compiler pass; its invoked as part of -! propagation. +IN: compiler.tree.propagation.copy ! Two values are copy-equivalent if they are always identical ! at run-time ("DS" relation). This is just a weak form of @@ -39,21 +36,7 @@ SYMBOL: copies GENERIC: compute-copy-equiv* ( node -- ) -M: #shuffle compute-copy-equiv* - [ out-d>> dup ] [ mapping>> ] bi - '[ , at ] map swap are-copies-of ; - -M: #>r compute-copy-equiv* - [ in-d>> ] [ out-r>> ] bi are-copies-of ; - -M: #r> compute-copy-equiv* - [ in-r>> ] [ out-d>> ] bi are-copies-of ; - -M: #copy compute-copy-equiv* - [ in-d>> ] [ out-d>> ] bi are-copies-of ; - -M: #return-recursive compute-copy-equiv* - [ in-d>> ] [ out-d>> ] bi are-copies-of ; +M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ; : compute-phi-equiv ( inputs outputs -- ) #! An output is a copy of every input if all inputs are diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index bc6f1d73e3..1c50914d19 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -3,7 +3,7 @@ USING: assocs classes classes.algebra kernel accessors math math.intervals namespaces sequences words combinators combinators.short-circuit arrays -compiler.tree.copy-equiv ; +compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info : false-class? ( class -- ? ) \ f class<= ; diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor index 10dd1a03c6..67a6b19d94 100644 --- a/unfinished/compiler/tree/propagation/nodes/nodes.factor +++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor @@ -3,7 +3,7 @@ USING: sequences accessors kernel assocs sequences compiler.tree compiler.tree.def-use -compiler.tree.copy-equiv +compiler.tree.propagation.copy compiler.tree.propagation.info ; IN: compiler.tree.propagation.nodes diff --git a/unfinished/compiler/tree/propagation/propagation.factor b/unfinished/compiler/tree/propagation/propagation.factor index 7fa971bafe..a31bfc4427 100755 --- a/unfinished/compiler/tree/propagation/propagation.factor +++ b/unfinished/compiler/tree/propagation/propagation.factor @@ -3,7 +3,7 @@ USING: accessors kernel sequences namespaces hashtables compiler.tree compiler.tree.def-use -compiler.tree.copy-equiv +compiler.tree.propagation.copy compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.simple @@ -13,6 +13,8 @@ compiler.tree.propagation.constraints compiler.tree.propagation.known-words ; IN: compiler.tree.propagation +! This pass must run after normalization + : propagate ( node -- node ) H{ } clone copies set H{ } clone constraints set diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 9e1bf52bbf..0e3af85b20 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -4,8 +4,8 @@ USING: kernel sequences accessors arrays fry math.intervals combinators namespaces stack-checker.inlining compiler.tree -compiler.tree.copy-equiv compiler.tree.combinators +compiler.tree.propagation.copy compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.simple diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor index 196c3e3658..016afc3e89 100755 --- a/unfinished/compiler/tree/tree.factor +++ b/unfinished/compiler/tree/tree.factor @@ -39,7 +39,9 @@ TUPLE: #push < node literal out-d ; swap 1array >>out-d swap >>literal ; -TUPLE: #shuffle < node mapping in-d out-d ; +TUPLE: #renaming < node ; + +TUPLE: #shuffle < #renaming mapping in-d out-d ; : #shuffle ( inputs outputs mapping -- node ) \ #shuffle new @@ -50,14 +52,14 @@ TUPLE: #shuffle < node mapping in-d out-d ; : #drop ( inputs -- node ) { } { } #shuffle ; -TUPLE: #>r < node in-d out-r ; +TUPLE: #>r < #renaming in-d out-r ; : #>r ( inputs outputs -- node ) \ #>r new swap >>out-r swap >>in-d ; -TUPLE: #r> < node in-r out-d ; +TUPLE: #r> < #renaming in-r out-d ; : #r> ( inputs outputs -- node ) \ #r> new @@ -126,7 +128,7 @@ TUPLE: #enter-recursive < node in-d out-d label ; swap >>in-d swap >>label ; -TUPLE: #return-recursive < node in-d out-d label ; +TUPLE: #return-recursive < #renaming in-d out-d label ; : #return-recursive ( label inputs outputs -- node ) \ #return-recursive new @@ -134,7 +136,7 @@ TUPLE: #return-recursive < node in-d out-d label ; swap >>in-d swap >>label ; -TUPLE: #copy < node in-d out-d ; +TUPLE: #copy < #renaming in-d out-d ; : #copy ( inputs outputs -- node ) \ #copy new @@ -143,6 +145,14 @@ TUPLE: #copy < node in-d out-d ; : node, ( node -- ) stack-visitor get push ; +GENERIC: inputs/outputs ( #renaming -- inputs outputs ) + +M: #shuffle inputs/outputs mapping>> unzip swap ; +M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ; +M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ; +M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ; +M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ; + M: vector child-visitor V{ } clone ; M: vector #introduce, #introduce node, ; M: vector #call, #call node, ; diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor new file mode 100644 index 0000000000..6b49502722 --- /dev/null +++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -0,0 +1,109 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.tuple-unboxing + +! This pass must run after escape analysis + +! Mapping from values to sequences of values +SYMBOL: unboxed-tuples + +: unboxed-tuple ( value -- unboxed-tuple ) + unboxed-tuples get at ; + +GENERIC: unbox-tuples* ( node -- ) + +: value-info-slots ( info -- slots ) + #! Delegation. + [ info>> ] [ class>> ] bi { + { [ dup tuple class<= ] [ drop 2 tail ] } + { [ dup complex class<= ] [ drop ] } + } cond ; + +: prepare-unboxed-values ( #push -- values ) + out-d>> first unboxed-allocation ; + +: prepare-unboxed-info ( #push -- infos values ) + dup prepare-unboxed-values dup + [ [ node-output-infos first value-info-slots ] dip ] + [ 2drop f f ] + if ; + +: expand-#push ( #push infos values -- ) + [ [ literal>> ] dip #push ] 2map >>body drop ; + +M: #push unbox-tuples* ( #push -- ) + dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ; + +: expand- ( #call values -- quot ) + [ drop in-d>> peek #drop ] + [ [ in-d>> but-last ] dip #copy ] + 2bi 2array ; + +: expand- ( #call values -- quot ) + [ in-d>> ] dip #copy 1array ; + +: expand-constructor ( #call values -- ) + [ drop ] [ ] [ drop word>> ] 2tri { + { [ expand- ] } + { [ expand- ] } + } case unbox-tuples >>body ; + +: unbox-constructor ( #call -- ) + dup prepare-unboxed-values dup + [ expand-constructor ] [ 2drop ] if ; + +: (flatten-values) ( values -- values' ) + [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ; + +: flatten-values ( values -- values' ) + (flatten-values) flatten ; + +: flatten-value ( values -- values ) + 1array flatten-values ; + +: prepare-slot-access ( #call -- tuple-values slot-values outputs ) + [ in-d>> first flatten-value ] + [ + [ dup in-d>> second node-value-info literal>> ] + [ out-d>> first unboxed-allocation ] + bi nth flatten-value + ] + [ out-d>> flatten-values ] + tri ; + +: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle ) + [ nip ] [ zip ] 2bi #shuffle ; + +: unbox-slot-access ( #call -- ) + dup unboxed-slot-access? [ + dup + [ in-d>> second 1array #drop ] + [ prepare-slot-access slot-access-shuffle ] + bi 2array unbox-tuples >>body + ] when drop ; + +M: #call unbox-tuples* ( #call -- ) + dup word>> { + { \ [ unbox- ] } + { \ [ unbox- ] } + { \ slot [ unbox-slot-access ] } + [ 2drop ] + } case ; + +M: #copy ... ; + +M: #>r ... ; + +M: #r> ... ; + +M: #shuffle ... ; + +M: #terrible ... ; + +! These nodes never participate in unboxing +M: #return drop ; + +M: #introduce drop ; + +: unbox-tuples ( nodes -- nodes ) + dup [ unbox-tuples* ] each-node ; diff --git a/unfinished/compiler/tree/untupling/untupling-tests.factor b/unfinished/compiler/tree/untupling/untupling-tests.factor deleted file mode 100644 index 27d8a66153..0000000000 --- a/unfinished/compiler/tree/untupling/untupling-tests.factor +++ /dev/null @@ -1,50 +0,0 @@ -IN: compiler.tree.untupling.tests -USING: assocs math kernel quotations.private slots.private -compiler.tree.builder -compiler.tree.def-use -compiler.tree.copy-equiv -compiler.tree.untupling -tools.test ; - -: check-untupling ( quot -- sizes ) - build-tree - compute-copy-equiv - compute-def-use - compute-untupling - values ; - -[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test - -[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test - -[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test - -[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test - -[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test - -[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test - -[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test - -[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test - -[ { 2 2 } ] [ - [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling -] unit-test - -[ { } ] [ - [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling -] unit-test - -[ { 2 2 2 } ] [ - [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling -] unit-test - -[ { 2 2 } ] [ - [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling -] unit-test - -[ { } ] [ - [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling -] unit-test diff --git a/unfinished/compiler/tree/untupling/untupling.factor b/unfinished/compiler/tree/untupling/untupling.factor deleted file mode 100644 index 7286e6fb65..0000000000 --- a/unfinished/compiler/tree/untupling/untupling.factor +++ /dev/null @@ -1,59 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors slots.private kernel namespaces disjoint-sets -math sequences assocs classes.tuple.private combinators fry sets -compiler.tree compiler.tree.combinators compiler.tree.copy-equiv -compiler.tree.dataflow-analysis -compiler.tree.dataflow-analysis.backward ; -IN: compiler.tree.untupling - -SYMBOL: escaping-values - -: mark-escaping-values ( node -- ) - in-d>> escaping-values get '[ resolve-copy , conjoin ] each ; - -SYMBOL: untupling-candidates - -: untupling-candidate ( #call class -- ) - #! 1- for delegate - size>> 1- swap out-d>> first resolve-copy - untupling-candidates get set-at ; - -GENERIC: compute-untupling* ( node -- ) - -M: #call compute-untupling* - dup word>> { - { \ [ dup in-d>> peek untupling-candidate ] } - { \ curry [ \ curry tuple-layout untupling-candidate ] } - { \ compose [ \ compose tuple-layout untupling-candidate ] } - { \ slot [ drop ] } - [ drop mark-escaping-values ] - } case ; - -M: #return compute-untupling* mark-escaping-values ; - -M: node compute-untupling* drop ; - -GENERIC: check-consistency* ( node -- ) - -: check-value-consistency ( out-value in-values -- ) - swap escaping-values get key? [ - escaping-values get '[ , conjoin ] each - ] [ - untupling-candidates get 2dup '[ , at ] map all-equal? - [ 2drop ] [ '[ , delete-at ] each ] if - ] if ; - -M: #phi check-consistency* - [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ] - [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ] - bi ; - -M: node check-consistency* drop ; - -: compute-untupling ( node -- assoc ) - H{ } clone escaping-values set - H{ } clone untupling-candidates set - [ [ compute-untupling* ] each-node ] - [ [ check-consistency* ] each-node ] bi - untupling-candidates get escaping-values get assoc-diff ; From 14b83dc2195f6bacd116f613f2411dae0e75b61e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Aug 2008 15:45:36 -0500 Subject: [PATCH 19/22] cfdg.models.rules08: Use new macros --- extra/cfdg/models/rules08/rules08.factor | 34 +++++++----------------- 1 file changed, 9 insertions(+), 25 deletions(-) diff --git a/extra/cfdg/models/rules08/rules08.factor b/extra/cfdg/models/rules08/rules08.factor index 20099d225a..f5398582c9 100644 --- a/extra/cfdg/models/rules08/rules08.factor +++ b/extra/cfdg/models/rules08/rules08.factor @@ -17,37 +17,21 @@ DEFER: line : ligne ( -- ) { - { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] do } + { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] } { 0.5 [ ] } } - call-random-weighted ; + rules ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: line ( -- ) [ insct ligne ] recursive ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: line ( -- ) { [ insct ligne ] } rule ; : sole ( -- ) - [ - { - { - 1 [ - [ 1 brightness 0.5 saturation ligne ] do - [ 140 r 1 hue sole ] do - ] - } - { 0.01 [ ] } - } - call-random-weighted - ] - recursive ; + { + { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] } + { 0.01 [ ] } + } + rules ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: centre ( -- ) - [ 1 b 5 s circle ] do - [ sole ] do ; +: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From f891a057aff5d440e93880f30703b45d9f8ac86a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Aug 2008 15:46:11 -0500 Subject: [PATCH 20/22] Move colors to basis --- {extra => basis}/colors/authors.txt | 0 {extra => basis}/colors/colors.factor | 0 {extra => basis}/colors/hsv/authors.txt | 0 {extra => basis}/colors/hsv/hsv.factor | 0 4 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/colors/authors.txt (100%) rename {extra => basis}/colors/colors.factor (100%) rename {extra => basis}/colors/hsv/authors.txt (100%) rename {extra => basis}/colors/hsv/hsv.factor (100%) diff --git a/extra/colors/authors.txt b/basis/colors/authors.txt similarity index 100% rename from extra/colors/authors.txt rename to basis/colors/authors.txt diff --git a/extra/colors/colors.factor b/basis/colors/colors.factor similarity index 100% rename from extra/colors/colors.factor rename to basis/colors/colors.factor diff --git a/extra/colors/hsv/authors.txt b/basis/colors/hsv/authors.txt similarity index 100% rename from extra/colors/hsv/authors.txt rename to basis/colors/hsv/authors.txt diff --git a/extra/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor similarity index 100% rename from extra/colors/hsv/hsv.factor rename to basis/colors/hsv/hsv.factor From d311893363bb8fda1d63f5b84955c3a79a235e37 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Aug 2008 17:10:17 -0500 Subject: [PATCH 21/22] ui.gadgets.theme: Use 'gray' color objects --- extra/ui/gadgets/theme/theme.factor | 38 ++++++++++++++--------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/extra/ui/gadgets/theme/theme.factor b/extra/ui/gadgets/theme/theme.factor index 20f560e309..46fa0105a3 100644 --- a/extra/ui/gadgets/theme/theme.factor +++ b/extra/ui/gadgets/theme/theme.factor @@ -18,41 +18,41 @@ IN: ui.gadgets.theme : plain-gradient T{ gradient f { - T{ rgba f 0.94 0.94 0.94 1.0 } - T{ rgba f 0.83 0.83 0.83 1.0 } - T{ rgba f 0.83 0.83 0.83 1.0 } - T{ rgba f 0.62 0.62 0.62 1.0 } + T{ gray f 0.94 1.0 } + T{ gray f 0.83 1.0 } + T{ gray f 0.83 1.0 } + T{ gray f 0.62 1.0 } } } ; : rollover-gradient T{ gradient f { - T{ rgba f 1.0 1.0 1.0 1.0 } - T{ rgba f 0.9 0.9 0.9 1.0 } - T{ rgba f 0.9 0.9 0.9 1.0 } - T{ rgba f 0.75 0.75 0.75 1.0 } + T{ gray f 1.0 1.0 } + T{ gray f 0.9 1.0 } + T{ gray f 0.9 1.0 } + T{ gray f 0.75 1.0 } } } ; : pressed-gradient T{ gradient f { - T{ rgba f 0.75 0.75 0.75 1.0 } - T{ rgba f 0.9 0.9 0.9 1.0 } - T{ rgba f 0.9 0.9 0.9 1.0 } - T{ rgba f 1.0 1.0 1.0 1.0 } + T{ gray f 0.75 1.0 } + T{ gray f 0.9 1.0 } + T{ gray f 0.9 1.0 } + T{ gray f 1.0 1.0 } } } ; : selected-gradient T{ gradient f { - T{ rgba f 0.65 0.65 0.65 1.0 } - T{ rgba f 0.8 0.8 0.8 1.0 } - T{ rgba f 0.8 0.8 0.8 1.0 } - T{ rgba f 1.0 1.0 1.0 1.0 } + T{ gray f 0.65 1.0 } + T{ gray f 0.8 1.0 } + T{ gray f 0.8 1.0 } + T{ gray f 1.0 1.0 } } } ; : lowered-gradient T{ gradient f { - T{ rgba f 0.37 0.37 0.37 1.0 } - T{ rgba f 0.43 0.43 0.43 1.0 } - T{ rgba f 0.5 0.5 0.5 1.0 } + T{ gray f 0.37 1.0 } + T{ gray f 0.43 1.0 } + T{ gray f 0.5 1.0 } } } ; : sans-serif-font { "sans-serif" plain 12 } ; From 708e24fcb0c22063b11a0a50d0a0f3cde449618d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Aug 2008 17:16:09 -0500 Subject: [PATCH 22/22] ui.gadgets.buttons: Minor '' update --- extra/ui/gadgets/buttons/buttons.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index c5a5e8bad8..d60901d993 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -199,14 +199,11 @@ M: radio-control model-changed : ( value model label -- gadget ) label-on-right radio-button-theme ; -: radio-buttons-theme ( gadget -- ) - { 5 5 } >>gap drop ; - : ( model assoc -- gadget ) -rot [ ] - dup radio-buttons-theme ; + { 5 5 } >>gap ; : ( value model label -- gadget ) bevel-button-theme ;