Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
b514829309
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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)" } "." }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -11,7 +11,7 @@ IN: math.primes.factors
|
|||
swap ;
|
||||
|
||||
: write-factor ( n d -- n' d' )
|
||||
2dup mod zero? [
|
||||
2dup divisor? [
|
||||
[ [ count-factor ] keep swap 2array , ] keep
|
||||
! If the remainder is a prime number, increase d so that
|
||||
! the caller stops looking for factors.
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ CONSTANT: horizontal { 1 0 }
|
|||
CONSTANT: vertical { 0 1 }
|
||||
|
||||
TUPLE: gadget < rect
|
||||
id
|
||||
pref-dim
|
||||
parent
|
||||
children
|
||||
|
|
@ -28,7 +29,7 @@ model ;
|
|||
|
||||
M: gadget equal? 2drop f ;
|
||||
|
||||
M: gadget hashcode* drop gadget hashcode* ;
|
||||
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
|
||||
|
||||
M: gadget model-changed 2drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
<shelf> +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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: draw-selection-background ( gadget -- )
|
||||
selection-background get background set
|
||||
selection-background get gl-color
|
||||
[ { 0 0 } ] dip dim>> 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 }
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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", "" };
|
||||
*/
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
/*
|
||||
# lol
|
||||
*/
|
||||
|
|
@ -0,0 +1 @@
|
|||
foo.h ftw
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#define FOO_H "foo.h"
|
||||
#include FOO_H
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#if 4 > (5 - 4++)
|
||||
#error "Umm"
|
||||
#endif
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#if 10
|
||||
#error "Umm"
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#define TABSIZE 100
|
||||
|
||||
int table[TABSIZE];
|
||||
|
|
@ -0,0 +1 @@
|
|||
#define max(a, b) ((a) > (b) ? (a) : (b))
|
||||
|
|
@ -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() };
|
||||
|
|
@ -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)
|
||||
|
|
@ -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(,,) };
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
||||
: <run-vocab-button> ( vocab-name -- button )
|
||||
dup '[ drop [ _ run ] call-listener ] <border-button> ;
|
||||
dup '[ drop [ _ run ] \ run call-listener ] <border-button> ;
|
||||
|
||||
: <demo-runner> ( -- gadget )
|
||||
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
|
||||
<pile> 1 >>fill { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
|
||||
|
||||
: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: demos ( -- ) [ <demo-runner> { 2 2 } <border> <scroller> "Demos" open-window ] with-ui ;
|
||||
|
||||
MAIN: demos
|
||||
|
|
@ -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. ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -6,20 +6,20 @@ IN: peg.pl0
|
|||
|
||||
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
|
||||
|
||||
EBNF: pl0
|
||||
EBNF: pl0
|
||||
|
||||
block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
|
||||
{ "VAR" ident { "," ident }* ";" }?
|
||||
{ "PROCEDURE" ident ";" { block ";" }? }* statement
|
||||
statement = { ident ":=" expression
|
||||
| "CALL" ident
|
||||
| "BEGIN" statement { ";" statement }* "END"
|
||||
| "IF" condition "THEN" statement
|
||||
| "WHILE" condition "DO" statement }?
|
||||
block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
|
||||
{ "VAR" ident { "," ident }* ";" }?
|
||||
{ "PROCEDURE" ident ";" { block ";" }? }* statement
|
||||
statement = { ident ":=" expression
|
||||
| "CALL" ident
|
||||
| "BEGIN" statement { ";" statement }* "END"
|
||||
| "IF" condition "THEN" statement
|
||||
| "WHILE" condition "DO" statement }?
|
||||
condition = { "ODD" expression }
|
||||
| { expression ("=" | "#" | "<=" | "<" | ">=" | ">") 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> ]]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
|||
<PRIVATE
|
||||
|
||||
: source-004 ( -- seq )
|
||||
100 999 [a,b] [ 10 mod 0 = not ] filter ;
|
||||
100 999 [a,b] [ 10 divisor? not ] filter ;
|
||||
|
||||
: max-palindrome ( seq -- palindrome )
|
||||
natural-sort [ palindrome? ] find-last nip ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit kernel make math math.ranges
|
||||
sequences project-euler.common ;
|
||||
USING: combinators.short-circuit kernel make math math.functions math.ranges
|
||||
sequences project-euler.common ;
|
||||
IN: project-euler.014
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=14
|
||||
|
|
@ -59,7 +59,7 @@ PRIVATE>
|
|||
<PRIVATE
|
||||
|
||||
: worth-calculating? ( n -- ? )
|
||||
1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
|
||||
1- 3 { [ divisor? ] [ / even? ] } 2&& ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
|||
<PRIVATE
|
||||
|
||||
: subseq-divisible? ( n index seq -- ? )
|
||||
[ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ;
|
||||
[ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
|
||||
|
||||
: interesting? ( seq -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
USING: project-euler.049 tools.test ;
|
||||
IN: project-euler.049.tests
|
||||
|
||||
[ 296962999629 ] [ euler049 ] unit-test
|
||||
|
|
@ -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
|
||||
! --------
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: count-digits ( n -- byte-array )
|
||||
10 <byte-array> [
|
||||
'[ 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
|
||||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -58,6 +58,7 @@
|
|||
(number constant "integers and floats")
|
||||
(ratio constant "ratios")
|
||||
(declaration keyword "declaration words")
|
||||
(ebnf-form constant "EBNF: ... ;EBNF form")
|
||||
(parsing-word keyword "parsing words")
|
||||
(setter-word function-name "setter words (>>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)
|
||||
|
|
|
|||
|
|
@ -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 "<b"))
|
||||
("\\_<\\(\"\\)>\\_>" (1 ">b"))
|
||||
;; Multiline constructs
|
||||
("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
|
||||
("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
|
||||
("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
|
||||
("\\_<USING:\\( \\)" (1 "<b"))
|
||||
("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue