diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 104941ddb2..7a03fe4408 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.functions namespaces sequences -strings system vocabs.loader threads accessors combinators -locals classes.tuple math.order summary combinators.short-circuit ; +USING: accessors arrays classes.tuple combinators combinators.short-circuit + kernel locals math math.functions math.order namespaces sequences strings + summary system threads vocabs.loader ; IN: calendar HOOK: gmt-offset os ( -- hours minutes seconds ) @@ -136,7 +136,7 @@ CONSTANT: day-abbreviations3 GENERIC: leap-year? ( obj -- ? ) M: integer leap-year? ( year -- ? ) - dup 100 mod zero? 400 4 ? mod zero? ; + dup 100 divisor? 400 4 ? divisor? ; M: timestamp leap-year? ( timestamp -- ? ) year>> leap-year? ; @@ -348,7 +348,7 @@ M: duration time- #! good for any date since October 15, 1582 [ dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when - [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip + [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip [ 1+ 3 * 5 /i + ] keep 2 * + ] dip 1+ + 7 mod ; diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 66d864b2a0..d880af5b55 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -60,7 +60,7 @@ M: topic url-of topic>filename ; : help>html ( topic -- xml ) [ article-title ] [ drop help-stylesheet ] - [ [ help ] with-html-writer ] + [ [ print-topic ] with-html-writer ] tri simple-page ; : generate-help-file ( topic -- ) diff --git a/basis/help/tips/tips-docs.factor b/basis/help/tips/tips-docs.factor index 750eff7a52..48ed65b318 100644 --- a/basis/help/tips/tips-docs.factor +++ b/basis/help/tips/tips-docs.factor @@ -20,6 +20,8 @@ TIP: "Power tools: " { $links see edit help about apropos time infer. } ; TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ; +TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $code "\"demos\" run" } ; + HELP: TIP: { $syntax "TIP: content ;" } { $values { "content" "a markup element" } } diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 33a5d96fc4..f7d0d5a941 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -13,7 +13,8 @@ ARTICLE: "integer-functions" "Integer functions" "Tests:" { $subsection power-of-2? } { $subsection even? } -{ $subsection odd? } ; +{ $subsection odd? } +{ $subsection divisor? } ; ARTICLE: "arithmetic-functions" "Arithmetic functions" "Computing additive and multiplicative inverses:" @@ -269,6 +270,11 @@ HELP: gcd { $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } } { $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ; +HELP: divisor? +{ $values { "m" integer } { "n" integer } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." } +{ $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ; + HELP: mod-inv { $values { "x" integer } { "n" integer } { "y" integer } } { $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." } diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 9f5ce36be1..4c9d151fd8 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -32,13 +32,13 @@ IN: math.functions.tests [ 1.0 ] [ 0 cosh ] unit-test [ 0.0 ] [ 1 acosh ] unit-test - + [ 1.0 ] [ 0 cos ] unit-test [ 0.0 ] [ 1 acos ] unit-test - + [ 0.0 ] [ 0 sinh ] unit-test [ 0.0 ] [ 0 asinh ] unit-test - + [ 0.0 ] [ 0 sin ] unit-test [ 0.0 ] [ 0 asin ] unit-test @@ -97,11 +97,17 @@ IN: math.functions.tests : verify-gcd ( a b -- ? ) 2dup gcd - [ rot * swap rem ] dip = ; + [ rot * swap rem ] dip = ; [ t ] [ 123 124 verify-gcd ] unit-test [ t ] [ 50 120 verify-gcd ] unit-test +[ t ] [ 0 42 divisor? ] unit-test +[ t ] [ 42 7 divisor? ] unit-test +[ t ] [ 42 -7 divisor? ] unit-test +[ t ] [ 42 42 divisor? ] unit-test +[ f ] [ 42 16 divisor? ] unit-test + [ 3 ] [ 5 7 mod-inv ] unit-test [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test @@ -150,4 +156,4 @@ IN: math.functions.tests 1067811677921310779 2135623355842621559 [ >bignum ] tri@ ^mod -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index a87b3995d7..1eac321e3b 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -111,6 +111,9 @@ PRIVATE> : lcm ( a b -- c ) [ * ] 2keep gcd nip /i ; foldable +: divisor? ( m n -- ? ) + mod 0 = ; + : mod-inv ( x n -- y ) [ nip ] [ gcd 1 = ] 2bi [ dup 0 < [ + ] [ nip ] if ] @@ -198,7 +201,7 @@ M: real sin fsin ; GENERIC: sinh ( x -- y ) foldable -M: complex sinh +M: complex sinh >float-rect [ [ fsinh ] [ fcos ] bi* * ] [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ; diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 199b72b7e1..278bf70b3d 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators kernel make math math.primes sequences ; +USING: arrays combinators kernel make math math.functions math.primes sequences ; IN: math.primes.factors > ; M: gadget model-changed 2drop ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 41e983eb28..6f6e7ee95f 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -49,13 +49,13 @@ M: pane-stream stream-element-type drop +character+ ; : pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ; inline -: selected-children ( pane -- seq ) +: selected-subtree ( pane -- seq ) [ pane-caret&mark sort-pair ] keep gadget-subtree ; M: pane gadget-selection? pane-caret&mark and ; M: pane gadget-selection ( pane -- string/f ) - selected-children gadget-text ; + selected-subtree gadget-text ; : init-prototype ( pane -- pane ) +baseline+ >>align >>prototype ; inline @@ -72,32 +72,12 @@ M: pane gadget-selection ( pane -- string/f ) [ >>last-line ] [ 1 track-add ] bi dup prepare-last-line ; inline -GENERIC: draw-selection ( loc obj -- ) - -: if-fits ( rect quot -- ) - [ clip get origin get vneg offset-rect over contains-rect? ] dip - [ drop ] if ; inline - -M: gadget draw-selection ( loc gadget -- ) - swap offset-rect [ - rect-bounds gl-fill-rect - ] if-fits ; - -M: node draw-selection ( loc node -- ) - 2dup value>> swap offset-rect [ - drop 2dup - [ value>> loc>> v+ ] keep - children>> [ draw-selection ] with each - ] if-fits 2drop ; - -M: pane draw-gadget* +M: pane selected-children dup gadget-selection? [ - [ selection-color>> gl-color ] - [ - [ loc>> vneg ] keep selected-children - [ draw-selection ] with each - ] bi - ] [ drop ] if ; + [ selected-subtree leaves ] + [ selection-color>> ] + bi + ] [ drop f f ] if ; : scroll-pane ( pane -- ) dup scrolls?>> [ scroll>bottom ] [ drop ] if ; diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 4c8f7c24e5..09c26fd271 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math.rectangles math.vectors namespaces kernel accessors -combinators sequences opengl opengl.gl opengl.glu colors +assocs combinators sequences opengl opengl.gl opengl.glu colors colors.constants ui.gadgets ui.pens ; IN: ui.render @@ -55,21 +55,57 @@ SYMBOL: origin GENERIC: draw-children ( gadget -- ) +! For gadget selection +SYMBOL: selected-gadgets + +SYMBOL: selection-background + +GENERIC: selected-children ( gadget -- assoc/f selection-background ) + +M: gadget selected-children drop f f ; + +! For text rendering +SYMBOL: background + +SYMBOL: foreground + +GENERIC: gadget-background ( gadget -- color ) + +M: gadget gadget-background dup interior>> pen-background ; + +GENERIC: gadget-foreground ( gadget -- color ) + +M: gadget gadget-foreground dup interior>> pen-foreground ; + +> gl-fill-rect ; + +: draw-standard-background ( object -- ) + dup interior>> dup [ draw-interior ] [ 2drop ] if ; + +: draw-background ( gadget -- ) + origin get [ + [ + dup selected-gadgets get key? + [ draw-selection-background ] + [ draw-standard-background ] if + ] [ draw-gadget* ] bi + ] with-translation ; + +: draw-border ( object -- ) + dup boundary>> dup [ + origin get [ draw-boundary ] with-translation + ] [ 2drop ] if ; + +PRIVATE> + : (draw-gadget) ( gadget -- ) dup loc>> origin get v+ origin [ - [ - origin get [ - [ dup interior>> dup [ draw-interior ] [ 2drop ] if ] - [ draw-gadget* ] - bi - ] with-translation - ] - [ draw-children ] - [ - dup boundary>> dup [ - origin get [ draw-boundary ] with-translation - ] [ 2drop ] if - ] tri + [ draw-background ] [ draw-children ] [ draw-border ] tri ] with-variable ; : >absolute ( rect -- rect ) @@ -88,27 +124,24 @@ GENERIC: draw-children ( gadget -- ) [ [ (draw-gadget) ] with-clipping ] } cond ; -! For text rendering -SYMBOL: background - -SYMBOL: foreground - -GENERIC: gadget-background ( gadget -- color ) - -M: gadget gadget-background dup interior>> pen-background ; - -GENERIC: gadget-foreground ( gadget -- color ) - -M: gadget gadget-foreground dup interior>> pen-foreground ; - M: gadget draw-children - [ visible-children ] - [ gadget-background ] - [ gadget-foreground ] tri [ - [ foreground set ] when* - [ background set ] when* - [ draw-gadget ] each - ] with-scope ; + dup children>> [ + { + [ visible-children ] + [ selected-children ] + [ gadget-background ] + [ gadget-foreground ] + } cleave [ + + { + [ [ selected-gadgets set ] when* ] + [ [ selection-background set ] when* ] + [ [ background set ] when* ] + [ [ foreground set ] when* ] + } spread + [ draw-gadget ] each + ] with-scope + ] [ drop ] if ; CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 } diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 63c656205c..9df084210d 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces make sequences kernel math arrays io -ui.gadgets generic combinators ; +ui.gadgets generic combinators fry sets ; IN: ui.traverse TUPLE: node value children ; @@ -85,3 +85,13 @@ M: node gadget-text* : gadget-at-path ( parent path -- gadget ) [ swap nth-gadget ] each ; + +GENERIC# leaves* 1 ( tree assoc -- ) + +M: node leaves* [ children>> ] dip leaves* ; + +M: array leaves* '[ _ leaves* ] each ; + +M: gadget leaves* conjoin ; + +: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ; \ No newline at end of file diff --git a/extra/c/preprocessor/preprocessor-tests.factor b/extra/c/preprocessor/preprocessor-tests.factor index d86b85a1b1..ba0531dfe7 100644 --- a/extra/c/preprocessor/preprocessor-tests.factor +++ b/extra/c/preprocessor/preprocessor-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test c.preprocessor kernel accessors ; +USING: tools.test c.preprocessor kernel accessors multiline ; IN: c.preprocessor.tests [ "vocab:c/tests/test1/test1.c" start-preprocess-file ] @@ -9,8 +9,18 @@ IN: c.preprocessor.tests [ "yo\n\n\n\nyo4\n" ] [ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test +/* [ "vocab:c/tests/test3/test3.c" start-preprocess-file ] [ "\"BOO\"" = ] must-fail-with +*/ [ V{ "\"omg\"" "\"lol\"" } ] [ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test + + +/* +f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1); +f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1); +int i[] = { 1, 23, 4, 5, }; +char c[2][6] = { "hello", "" }; +*/ diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index 89292eb74b..f7cd10a0e9 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -3,24 +3,41 @@ USING: html.parser.state io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories -assocs math splitting make ; +assocs math splitting make unicode.categories +combinators.short-circuit ; IN: c.preprocessor : initial-library-paths ( -- seq ) V{ "/usr/include" } clone ; +: initial-symbol-table ( -- hashtable ) + H{ + { "__APPLE__" "" } + { "__amd64__" "" } + { "__x86_64__" "" } + } clone ; + TUPLE: preprocessor-state library-paths symbol-table include-nesting include-nesting-max processing-disabled? -ifdef-nesting warnings ; +ifdef-nesting warnings errors +pragmas +include-nexts +ifs elifs elses ; : ( -- preprocessor-state ) preprocessor-state new initial-library-paths >>library-paths - H{ } clone >>symbol-table + initial-symbol-table >>symbol-table 0 >>include-nesting 200 >>include-nesting-max 0 >>ifdef-nesting - V{ } clone >>warnings ; + V{ } clone >>warnings + V{ } clone >>errors + V{ } clone >>pragmas + V{ } clone >>include-nexts + V{ } clone >>ifs + V{ } clone >>elifs + V{ } clone >>elses ; DEFER: preprocess-file @@ -64,8 +81,13 @@ ERROR: header-file-missing path ; : readlns ( -- string ) [ (readlns) ] { } make concat ; +: take-define-identifier ( state-parser -- string ) + skip-whitespace + [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; + : handle-define ( preprocessor-state state-parser -- ) - [ take-token ] [ take-rest ] bi + [ take-define-identifier ] + [ skip-whitespace take-rest ] bi "\\" ?tail [ readlns append ] when spin symbol-table>> set-at ; @@ -86,9 +108,25 @@ ERROR: header-file-missing path ; : handle-endif ( preprocessor-state state-parser -- ) drop [ 1 - ] change-ifdef-nesting drop ; +: handle-if ( preprocessor-state state-parser -- ) + [ [ 1 + ] change-ifdef-nesting ] dip + skip-whitespace take-rest swap ifs>> push ; + +: handle-elif ( preprocessor-state state-parser -- ) + skip-whitespace take-rest swap elifs>> push ; + +: handle-else ( preprocessor-state state-parser -- ) + skip-whitespace take-rest swap elses>> push ; + +: handle-pragma ( preprocessor-state state-parser -- ) + skip-whitespace take-rest swap pragmas>> push ; + +: handle-include-next ( preprocessor-state state-parser -- ) + skip-whitespace take-rest swap include-nexts>> push ; + : handle-error ( preprocessor-state state-parser -- ) - skip-whitespace - nip take-rest throw ; + skip-whitespace take-rest swap errors>> push ; + ! nip take-rest throw ; : handle-warning ( preprocessor-state state-parser -- ) skip-whitespace @@ -104,11 +142,11 @@ ERROR: header-file-missing path ; { "ifdef" [ handle-ifdef ] } { "ifndef" [ handle-ifndef ] } { "endif" [ handle-endif ] } - { "if" [ 2drop ] } - { "elif" [ 2drop ] } - { "else" [ 2drop ] } - { "pragma" [ 2drop ] } - { "include_next" [ 2drop ] } + { "if" [ handle-if ] } + { "elif" [ handle-elif ] } + { "else" [ handle-else ] } + { "pragma" [ handle-pragma ] } + { "include_next" [ handle-include-next ] } [ unknown-c-preprocessor ] } case ; diff --git a/extra/c/tests/test10/test10.c b/extra/c/tests/test10/test10.c new file mode 100644 index 0000000000..7f38e70d73 --- /dev/null +++ b/extra/c/tests/test10/test10.c @@ -0,0 +1,3 @@ +/* +# lol +*/ diff --git a/extra/c/tests/test11/foo.h b/extra/c/tests/test11/foo.h new file mode 100644 index 0000000000..381b7535a0 --- /dev/null +++ b/extra/c/tests/test11/foo.h @@ -0,0 +1 @@ +foo.h ftw diff --git a/extra/c/tests/test11/test11.c b/extra/c/tests/test11/test11.c new file mode 100644 index 0000000000..1b05118b01 --- /dev/null +++ b/extra/c/tests/test11/test11.c @@ -0,0 +1,2 @@ +#define FOO_H "foo.h" +#include FOO_H diff --git a/extra/c/tests/test12/test12.c b/extra/c/tests/test12/test12.c new file mode 100644 index 0000000000..2da127bce0 --- /dev/null +++ b/extra/c/tests/test12/test12.c @@ -0,0 +1,3 @@ +#if 4 > (5 - 4++) +#error "Umm" +#endif diff --git a/extra/c/tests/test13/test13.c b/extra/c/tests/test13/test13.c new file mode 100644 index 0000000000..13c48ff6d0 --- /dev/null +++ b/extra/c/tests/test13/test13.c @@ -0,0 +1,2 @@ +#if 10 +#error "Umm" diff --git a/extra/c/tests/test14/test14.c b/extra/c/tests/test14/test14.c new file mode 100644 index 0000000000..1697ea1697 --- /dev/null +++ b/extra/c/tests/test14/test14.c @@ -0,0 +1,15 @@ +#if 4 > (1 + 2) +good +#endif + +#if 4 > 1 + 2 +good +#endif + +#if (4 > 1) - 1 +bad +#endif + +#if (4 > 1) - 2 +good +#endif diff --git a/extra/c/tests/test5/test5.c b/extra/c/tests/test5/test5.c new file mode 100644 index 0000000000..4c169640ef --- /dev/null +++ b/extra/c/tests/test5/test5.c @@ -0,0 +1,3 @@ +#define TABSIZE 100 + +int table[TABSIZE]; diff --git a/extra/c/tests/test6/test6.c b/extra/c/tests/test6/test6.c new file mode 100644 index 0000000000..3b0353a518 --- /dev/null +++ b/extra/c/tests/test6/test6.c @@ -0,0 +1 @@ +#define max(a, b) ((a) > (b) ? (a) : (b)) diff --git a/extra/c/tests/test7/test7.c b/extra/c/tests/test7/test7.c new file mode 100644 index 0000000000..4d5e66ba24 --- /dev/null +++ b/extra/c/tests/test7/test7.c @@ -0,0 +1,19 @@ +#define x 3 +#define f(a) f(x * (a)) +#undef x +#define x 2 +#define g f +#define z z[0] +#define h g(~ +#define m(a) a(w) +#define w 0,1 +#define t(a) a +#define p() int +#define q(x) x +#define r(x,y) x ## y +#define str(x) # x +f(y+1) + f(f(z)) % t(t(g)(0) + t)(1); +g(x+(3,4)-w) | h 5) & m +(f)^m(m); +p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) }; +char c[2][6] = { str(hello), str() }; diff --git a/extra/c/tests/test8/test8.c b/extra/c/tests/test8/test8.c new file mode 100644 index 0000000000..bc1e27348d --- /dev/null +++ b/extra/c/tests/test8/test8.c @@ -0,0 +1,15 @@ +#define str(s) #s +#define xstr(s) str(s) +#define debug(s, t) printf("x" # s "= %d, x" # t "= %s", \ +x ## s, x ## t) +#define INCFILE(n) vers ## n +#define glue(a, b) a## b +#define xglue(a, b) glue(a, b) +#define HIGHLOW "hello" +#define LOW LOW ", world" +debug(1, 2); +fputs(str(strncmp("abc\0d", "abc", '\4') //this goes away +== 0) str(: @\n), s); +#include xstr(INCFILE(2).h) +glue(HIGH, LOW); +xglue(HIGH, LOW) diff --git a/extra/c/tests/test9/test9.c b/extra/c/tests/test9/test9.c new file mode 100644 index 0000000000..86940cfbea --- /dev/null +++ b/extra/c/tests/test9/test9.c @@ -0,0 +1,4 @@ +#define t(x,y,z) x ## y ## z +int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,), +t(10,,), t(,11,), t(,,12), t(,,) }; + diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor index 8c55945105..dfd73f1236 100644 --- a/extra/demos/demos.factor +++ b/extra/demos/demos.factor @@ -1,22 +1,16 @@ - -USING: kernel fry sequences - vocabs.loader help.vocabs - ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers - ui.tools.listener - accessors ; - +USING: kernel fry sequences vocabs.loader help.vocabs ui +ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders +ui.gadgets.scrollers ui.tools.listener accessors ; IN: demos : demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ; : ( vocab-name -- button ) - dup '[ drop [ _ run ] call-listener ] ; + dup '[ drop [ _ run ] \ run call-listener ] ; : ( -- gadget ) - 1 >>fill demo-vocabs [ add-gadget ] each ; + 1 >>fill { 2 2 } >>gap demo-vocabs [ add-gadget ] each ; -: demos ( -- ) [ "Demos" open-window ] with-ui ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: demos ( -- ) [ { 2 2 } "Demos" open-window ] with-ui ; MAIN: demos \ No newline at end of file diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index ba3438e37d..ceadc9fe6e 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -1,13 +1,16 @@ USING: words kernel sequences locals locals.parser locals.definitions accessors parser namespaces continuations -summary definitions generalizations arrays ; +summary definitions generalizations arrays prettyprint debugger io ; IN: descriptive ERROR: descriptive-error args underlying word ; -M: descriptive-error summary - word>> "The " swap name>> " word encountered an error." - 3append ; +M: descriptive-error error. + "The word " write dup word>> pprint " encountered an error." print + "Arguments:" print + dup args>> stack. + "Error:" print + underlying>> error. ; =" | ">") expression } -expression = {"+" | "-"}? term { {"+" | "-"} term }* -term = factor { {"*" | "/"} factor }* +expression = {"+" | "-"}? term { {"+" | "-"} term }* +term = factor { {"*" | "/"} factor }* factor = ident | number | "(" expression ")" ident = (([a-zA-Z])+) => [[ >string ]] digit = ([0-9]) => [[ digit> ]] diff --git a/extra/project-euler/001/001-tests.factor b/extra/project-euler/001/001-tests.factor index 8d2461a510..1cab275619 100644 --- a/extra/project-euler/001/001-tests.factor +++ b/extra/project-euler/001/001-tests.factor @@ -4,3 +4,4 @@ IN: project-euler.001.tests [ 233168 ] [ euler001 ] unit-test [ 233168 ] [ euler001a ] unit-test [ 233168 ] [ euler001b ] unit-test +[ 233168 ] [ euler001c ] unit-test diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index de4345db68..20e08242c5 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -1,6 +1,6 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.ranges sequences project-euler.common ; +USING: kernel math math.functions math.ranges sequences project-euler.common ; IN: project-euler.001 ! http://projecteuler.net/index.php?section=problems&id=1 @@ -51,4 +51,11 @@ PRIVATE> ! [ euler001b ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials + +: euler001c ( -- answer ) + 1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ; + +! [ euler001c ] 100 ave-time +! 0 ms ave run time - 0.06 SD (100 trials) + SOLUTION: euler001 diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor index ff62b4e181..fe09914d9f 100644 --- a/extra/project-euler/004/004.factor +++ b/extra/project-euler/004/004.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables kernel math math.ranges project-euler.common sequences - sorting sets ; +USING: hashtables kernel math math.functions math.ranges project-euler.common + sequences sorting sets ; IN: project-euler.004 ! http://projecteuler.net/index.php?section=problems&id=4 @@ -21,7 +21,7 @@ IN: project-euler.004 diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor index c7c3fea5da..780015ab77 100644 --- a/extra/project-euler/033/033.factor +++ b/extra/project-euler/033/033.factor @@ -33,7 +33,7 @@ IN: project-euler.033 10 99 [a,b] dup cartesian-product [ first2 < ] filter ; : safe? ( ax xb -- ? ) - [ 10 /mod ] bi@ -roll = rot zero? not and nip ; + [ 10 /mod ] bi@ [ = ] dip zero? not and nip ; : ax/xb ( ax xb -- z/f ) 2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ; diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index 7edcd14364..75241499e1 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit kernel math math.combinatorics math.parser - math.ranges project-euler.common sequences sets sorting ; +USING: combinators.short-circuit kernel math math.functions math.combinatorics + math.parser math.ranges project-euler.common sequences sets sorting ; IN: project-euler.043 ! http://projecteuler.net/index.php?section=problems&id=43 @@ -36,7 +36,7 @@ IN: project-euler.043 integer swap mod zero? ; + [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ; : interesting? ( seq -- ? ) { diff --git a/extra/project-euler/049/049-tests.factor b/extra/project-euler/049/049-tests.factor new file mode 100644 index 0000000000..679647ac18 --- /dev/null +++ b/extra/project-euler/049/049-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.049 tools.test ; +IN: project-euler.049.tests + +[ 296962999629 ] [ euler049 ] unit-test diff --git a/extra/project-euler/049/049.factor b/extra/project-euler/049/049.factor new file mode 100644 index 0000000000..15dd7ed6d2 --- /dev/null +++ b/extra/project-euler/049/049.factor @@ -0,0 +1,74 @@ +! Copyright (c) 2009 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays byte-arrays fry hints kernel math math.combinatorics + math.functions math.parser math.primes project-euler.common sequences sets ; +IN: project-euler.049 + +! http://projecteuler.net/index.php?section=problems&id=49 + +! DESCRIPTION +! ----------- + +! The arithmetic sequence, 1487, 4817, 8147, in which each of the terms +! increases by 3330, is unusual in two ways: (i) each of the three terms are +! prime, and, (ii) each of the 4-digit numbers are permutations of one another. + +! There are no arithmetic sequences made up of three 1-, 2-, or 3-digit primes, +! exhibiting this property, but there is one other 4-digit increasing sequence. + +! What 12-digit number do you form by concatenating the three terms in this +! sequence? + + +! SOLUTION +! -------- + + [ + '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop + ] keep ; + +HINTS: count-digits fixnum ; + +: permutations? ( n m -- ? ) + [ count-digits ] bi@ = ; + +: collect-permutations ( seq -- seq ) + [ V{ } clone ] [ dup ] bi* [ + dupd '[ _ permutations? ] filter + [ diff ] keep pick push + ] each drop ; + +: potential-sequences ( -- seq ) + 1000 9999 primes-between + collect-permutations [ length 3 >= ] filter ; + +: arithmetic-terms ( m n -- seq ) + 2dup [ swap - ] keep + 3array ; + +: (find-unusual-terms) ( n seq -- seq/f ) + [ [ arithmetic-terms ] with map ] keep + '[ _ [ peek ] dip member? ] find nip ; + +: find-unusual-terms ( seq -- seq/? ) + unclip-slice over (find-unusual-terms) [ + nip + ] [ + dup length 3 >= [ find-unusual-terms ] [ drop f ] if + ] if* ; + +: 4digit-concat ( seq -- str ) + 0 [ [ 10000 * ] dip + ] reduce ; + +PRIVATE> + +: euler049 ( -- answer ) + potential-sequences [ find-unusual-terms ] map sift + [ { 1487 4817 8147 } = not ] find nip 4digit-concat ; + +! [ euler049 ] 100 ave-time +! 206 ms ave run time - 10.25 SD (100 trials) + +SOLUTION: euler049 diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor index 1b3b9ba1f1..c25b1adcc0 100644 --- a/extra/project-euler/052/052.factor +++ b/extra/project-euler/052/052.factor @@ -1,8 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit kernel math - project-euler.common sequences sorting - grouping ; +USING: combinators.short-circuit kernel math math.functions + project-euler.common sequences sorting grouping ; IN: project-euler.052 ! http://projecteuler.net/index.php?section=problems&id=52 @@ -31,7 +30,7 @@ IN: project-euler.052 [ number>digits natural-sort ] map all-equal? ; : candidate? ( n -- ? ) - { [ odd? ] [ 3 mod 0 = ] } 1&& ; + { [ odd? ] [ 3 divisor? ] } 1&& ; : next-all-same ( x n -- n ) dup candidate? [ diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 423512465e..ba8c81fbf4 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -44,7 +44,7 @@ IN: project-euler.common : (sum-divisors) ( n -- sum ) dup sqrt >integer [1,b] [ - [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each + [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if ] { } make sum ; @@ -57,7 +57,7 @@ PRIVATE> >lower [ CHAR: a - 1+ ] sigma ; : cartesian-product ( seq1 seq2 -- seq1xseq2 ) - swap [ swap [ 2array ] with map ] with map concat ; + [ [ 2array ] with map ] curry map concat ; : log10 ( m -- n ) log 10 log / ; @@ -75,6 +75,9 @@ PRIVATE> : number>digits ( n -- seq ) [ dup 0 = not ] [ 10 /mod ] produce reverse nip ; +: number-length ( n -- m ) + log10 floor 1+ >integer ; + : nth-triangle ( n -- n ) dup 1+ * 2 / ; @@ -117,7 +120,7 @@ PRIVATE> factor-2s dup [ 1+ ] [ perfect-square? -1 0 ? ] [ dup sqrt >fixnum [1,b] ] tri* [ - dupd mod 0 = [ [ 2 + ] dip ] when + dupd divisor? [ [ 2 + ] dip ] when ] each drop * ; ! These transforms are for generating primitive Pythagorean triples @@ -134,4 +137,3 @@ SYNTAX: SOLUTION: [ drop in get vocab (>>main) ] [ [ . ] swap prefix (( -- )) define-declared ] 2bi ; - diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 3d10dbcfbd..1e1da38a3f 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -14,14 +14,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.045 project-euler.046 project-euler.047 project-euler.048 - project-euler.052 project-euler.053 project-euler.055 project-euler.056 - project-euler.057 project-euler.059 project-euler.067 project-euler.071 - project-euler.073 project-euler.075 project-euler.076 project-euler.079 - project-euler.092 project-euler.097 project-euler.099 project-euler.100 - project-euler.116 project-euler.117 project-euler.134 project-euler.148 - project-euler.150 project-euler.151 project-euler.164 project-euler.169 - project-euler.173 project-euler.175 project-euler.186 project-euler.190 - project-euler.203 project-euler.215 ; + project-euler.049 project-euler.052 project-euler.053 project-euler.055 + project-euler.056 project-euler.057 project-euler.059 project-euler.067 + project-euler.071 project-euler.073 project-euler.075 project-euler.076 + project-euler.079 project-euler.092 project-euler.097 project-euler.099 + project-euler.100 project-euler.116 project-euler.117 project-euler.134 + project-euler.148 project-euler.150 project-euler.151 project-euler.164 + project-euler.169 project-euler.173 project-euler.175 project-euler.186 + project-euler.190 project-euler.203 project-euler.215 ; IN: project-euler >foo)") (getter-word function-name "getter words (foo>>)") @@ -75,7 +76,9 @@ (defun fuel-font-lock--syntactic-face (state) (if (nth 3 state) 'factor-font-lock-string (let ((c (char-after (nth 8 state)))) - (cond ((or (char-equal c ?\ ) (char-equal c ?\n)) + (cond ((or (char-equal c ?\ ) + (char-equal c ?\n) + (char-equal c ?E)) (save-excursion (goto-char (nth 8 state)) (beginning-of-line) @@ -85,6 +88,8 @@ 'factor-font-lock-symbol) ((looking-at-p "C-ENUM:\\( \\|\n\\)") 'factor-font-lock-constant) + ((looking-at-p "E") + 'factor-font-lock-ebnf-form) (t 'default)))) ((or (char-equal c ?U) (char-equal c ?C)) 'factor-font-lock-parsing-word) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 4cff58ae3b..7aba6282d6 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -48,7 +48,7 @@ "B" "BIN:" "C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method" "DEFER:" - "ERROR:" "EXCLUDE:" + "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:" "f" "FORGET:" "FROM:" "FUNCTION:" "GENERIC#" "GENERIC:" "HELP:" "HEX:" "HOOK:" @@ -254,6 +254,8 @@ ("\\_<<\\(\"\\)\\_>" (1 "\\_>" (1 ">b")) ;; Multiline constructs + ("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "" (1 ">b")) ("\\_<\\(U\\)SING: \\(;\\)" (1 "b")) ("\\_b")) diff --git a/vm/platform.h b/vm/platform.h index 21336e88bb..70804542b4 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -96,7 +96,7 @@ #if defined(FACTOR_X86) #include "os-solaris-x86.32.h" #elif defined(FACTOR_AMD64) - #incluide "os-solaris-x86.64.h" + #include "os-solaris-x86.64.h" #else #error "Unsupported Solaris flavor" #endif