From 8ec695332a69dd193754394e2ddd774add9962c6 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 6 Nov 2008 23:21:19 -0500 Subject: [PATCH 01/83] Add reverse haar wavelet transform and tests --- extra/math/haar/authors.txt | 2 ++ extra/math/haar/haar-tests.factor | 5 +++++ extra/math/haar/haar.factor | 23 +++++++++++++++++++---- 3 files changed, 26 insertions(+), 4 deletions(-) create mode 100644 extra/math/haar/authors.txt create mode 100644 extra/math/haar/haar-tests.factor diff --git a/extra/math/haar/authors.txt b/extra/math/haar/authors.txt new file mode 100644 index 0000000000..cf46c0ea5e --- /dev/null +++ b/extra/math/haar/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Aaron Schaefer diff --git a/extra/math/haar/haar-tests.factor b/extra/math/haar/haar-tests.factor new file mode 100644 index 0000000000..9c9124bf17 --- /dev/null +++ b/extra/math/haar/haar-tests.factor @@ -0,0 +1,5 @@ +USING: math.haar tools.test ; +IN: math.haar.tests + +[ { 3 2 -1 -2 3 0 4 1 } ] [ { 7 1 6 6 3 -5 4 2 } haar ] unit-test +[ { 7 1 6 6 3 -5 4 2 } ] [ { 3 2 -1 -2 3 0 4 1 } rev-haar ] unit-test diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor index f1bf87161c..f745721124 100644 --- a/extra/math/haar/haar.factor +++ b/extra/math/haar/haar.factor @@ -1,15 +1,30 @@ -! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/ -USING: sequences math kernel splitting grouping columns ; +! Copyright (c) 2008 Slava Pestov, Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs columns grouping kernel math math.statistics math.vectors + sequences ; IN: math.haar +! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/ + +r 0 r> [ - ] 2map ; + [ 0 ] dip v- ; : haar-step ( seq -- differences averages ) 2 group dup averages [ differences ] keep ; +: rev-haar-step ( seq -- seq ) + halves [ v+ ] [ v- ] 2bi zip concat ; + +PRIVATE> + : haar ( seq -- seq ) dup length 1 <= [ haar-step haar prepend ] unless ; + +: rev-haar ( seq -- seq ) + dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ; + From 67ce49dc594b234c8f7fc96c5814190009698380 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 7 Nov 2008 01:24:32 -0500 Subject: [PATCH 02/83] Update syntax for extra/math vocabs --- extra/math/algebra/algebra.factor | 5 +- extra/math/combinatorics/combinatorics.factor | 2 +- extra/math/compare/compare.factor | 24 ++-- extra/math/derivatives/derivatives.factor | 111 ++++++++---------- extra/math/erato/erato.factor | 40 +++---- extra/math/erato/summary.txt | 2 +- .../math/function-tools/function-tools.factor | 25 ++-- .../matrices/elimination/elimination.factor | 18 +-- extra/math/matrices/matrices.factor | 7 +- extra/math/miller-rabin/miller-rabin.factor | 2 +- .../math/newtons-method/newtons-method.factor | 5 +- extra/math/secant-method/secant-method.factor | 5 +- 12 files changed, 121 insertions(+), 125 deletions(-) diff --git a/extra/math/algebra/algebra.factor b/extra/math/algebra/algebra.factor index 8cccded26a..82a2578a7f 100644 --- a/extra/math/algebra/algebra.factor +++ b/extra/math/algebra/algebra.factor @@ -1,10 +1,9 @@ -! Copyright (c) 2007 Samuel Tardieu +! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions sequences fry ; IN: math.algebra : chinese-remainder ( aseq nseq -- x ) - dup product - [ + dup product [ '[ _ over / [ swap gcd drop ] keep * * ] 2map sum ] keep rem ; foldable diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index 00a104b381..1bc692ca54 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -19,7 +19,7 @@ IN: math.combinatorics 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ; : (>permutation) ( seq n -- seq ) - [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ; + [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; diff --git a/extra/math/compare/compare.factor b/extra/math/compare/compare.factor index d19dac3d2b..826f0ecf16 100644 --- a/extra/math/compare/compare.factor +++ b/extra/math/compare/compare.factor @@ -1,21 +1,19 @@ -! Copyright (C) 2008 John Benediktsson +! Copyright (C) 2008 John Benediktsson. ! See http://factorcode.org/license.txt for BSD license - USING: math math.order kernel ; +IN: math.compare -IN: math.compare +: absmin ( a b -- x ) + [ [ abs ] bi@ < ] 2keep ? ; -: absmin ( a b -- x ) - [ [ abs ] bi@ < ] 2keep ? ; +: absmax ( a b -- x ) + [ [ abs ] bi@ > ] 2keep ? ; -: absmax ( a b -- x ) - [ [ abs ] bi@ > ] 2keep ? ; +: posmax ( a b -- x ) + 0 max max ; -: posmax ( a b -- x ) - 0 max max ; - -: negmin ( a b -- x ) - 0 min min ; +: negmin ( a b -- x ) + 0 min min ; : clamp ( a value b -- x ) - min max ; + min max ; diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index b7612e112b..7922a48a6b 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -1,6 +1,7 @@ -USING: kernel continuations combinators sequences math - math.order math.ranges accessors float-arrays ; - +! Copyright (c) 2008 Reginald Keith Ford II, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations combinators sequences math math.order math.ranges + accessors float-arrays ; IN: math.derivatives TUPLE: state x func h err i j errt fac hh ans a done ; @@ -20,7 +21,8 @@ TUPLE: state x func h err i j errt fac hh ans a done ; : a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ; : check-h ( state -- state ) - dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ; + dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ; + : init-a ( state -- state ) ntab [ ntab ] replicate >>a ; : init-hh ( state -- state ) dup h>> >>hh ; : init-err ( state -- state ) big >>err ; @@ -30,75 +32,66 @@ TUPLE: state x func h err i j errt fac hh ans a done ; ! If error is decreased, save the improved answer : error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ; + : save-improved-answer ( state -- state ) - dup err>> >>errt - dup a[j][i] >>ans ; + dup err>> >>errt + dup a[j][i] >>ans ; ! If higher order is worse by a significant factor SAFE, then quit early. : check-safe ( state -- state ) - dup - [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >= - [ t >>done ] - when ; + dup [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] + [ err>> safe * ] bi >= [ t >>done ] when ; + : x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ; : x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ; + : limit-approx ( state -- val ) - [ - [ [ x+hh ] [ func>> ] bi call ] - [ [ x-hh ] [ func>> ] bi call ] - bi - - ] - [ hh>> 2.0 * ] - bi / ; + [ + [ [ x+hh ] [ func>> ] bi call ] + [ [ x-hh ] [ func>> ] bi call ] bi - + ] [ hh>> 2.0 * ] bi / ; + : a[0][0]! ( state -- state ) - { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ; + { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ; + : a[0][i]! ( state -- state ) - { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ; + { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ; + : a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ; + : new-a[j][i] ( state -- val ) - [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ] - [ fac>> 1.0 - ] - bi / ; + [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ] + [ fac>> 1.0 - ] bi / ; + : a[j][i]! ( state -- state ) - { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ; + { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ; : update-errt ( state -- state ) - dup - [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ] - [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] - bi max - >>errt ; + dup [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ] + [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] bi max >>errt ; : not-done? ( state -- state ? ) dup done>> not ; : derive ( state -- state ) - init-a - check-h - init-hh - a[0][0]! - init-err - 1 ntab [a,b) - [ - >>i - not-done? - [ - update-hh - a[0][i]! - reset-fac - 1 over i>> [a,b] - [ - >>j - a[j][i]! - update-fac - update-errt - error-decreased? [ save-improved-answer ] when - ] - each - check-safe - ] - when - ] - each ; + init-a + check-h + init-hh + a[0][0]! + init-err + 1 ntab [a,b) [ + >>i not-done? [ + update-hh + a[0][i]! + reset-fac + 1 over i>> [a,b] [ + >>j + a[j][i]! + update-fac + update-errt + error-decreased? [ save-improved-answer ] when + ] each check-safe + ] when + ] each ; : derivative-state ( x func h err -- state ) state new @@ -112,11 +105,7 @@ TUPLE: state x func h err i j errt fac hh ans a done ; ! h should be small enough to give the correct sgn(f'(x)) ! err is the max tolerance of gain in error for a single iteration- : (derivative) ( x func h err -- ans error ) - derivative-state - derive - [ ans>> ] - [ errt>> ] - bi ; + derivative-state derive [ ans>> ] [ errt>> ] bi ; -: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ; +: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ; : derivative-func ( func -- der ) [ derivative ] curry ; diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 4c6675e8f1..894905e405 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: bit-arrays kernel lists.lazy math math.functions math.primes.list - math.ranges sequences accessors ; +USING: accessors bit-arrays fry kernel lists.lazy math math.functions + math.primes.list math.ranges sequences ; IN: math.erato > ] bi* nth ; inline + [ ind ] [ bits>> ] bi* nth ; inline : indices ( n erato -- range ) - limit>> ind over 3 * ind swap rot ; + limit>> ind over 3 * ind swap rot ; : mark-multiples ( n erato -- ) - over sq over limit>> <= - [ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ; + 2dup [ sq ] [ limit>> ] bi* <= [ + [ indices ] keep bits>> '[ _ f -rot set-nth ] each + ] [ 2drop ] if ; : ( n -- erato ) - dup ind 1+ 1 over set-bits erato boa ; + dup ind 1+ dup set-bits 1 erato boa ; : next-prime ( erato -- prime/f ) - [ 2 + ] change-latest [ latest>> ] keep - 2dup limit>> <= - [ - 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if - ] [ - 2drop f - ] if ; + [ 2 + ] change-latest [ latest>> ] keep + 2dup limit>> <= [ + 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if + ] [ + 2drop f + ] if ; PRIVATE> : lerato ( n -- lazy-list ) - dup 1000003 < [ - 0 primes-under-million seq>list swap [ <= ] curry lwhile - ] [ - 2 [ drop next-prime ] with lfrom-by [ ] lwhile - ] if ; + dup 1000003 < [ + 0 primes-under-million seq>list swap '[ _ <= ] lwhile + ] [ + 2 [ drop next-prime ] with lfrom-by [ ] lwhile + ] if ; diff --git a/extra/math/erato/summary.txt b/extra/math/erato/summary.txt index e8982fa3e0..ee15b7e06f 100644 --- a/extra/math/erato/summary.txt +++ b/extra/math/erato/summary.txt @@ -1 +1 @@ -Sieve of Eratosthene +Sieve of Eratosthenes diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor index ec93a0891a..3bc785c1b6 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -1,9 +1,18 @@ -! Copyright © 2008 Reginald Keith Ford II -! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions - +! Copyright (c) 2008 Reginald Keith Ford II. +! See http://factorcode.org/license.txt for BSD license. USING: kernel math arrays sequences sequences.lib ; -IN: math.function-tools -: difference-func ( func func -- func ) [ bi - ] 2curry ; inline -: eval ( x func -- pt ) dupd call 2array ; inline -: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline -: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline +IN: math.function-tools + +! Tools for quickly comparing, transforming, and evaluating mathematical functions + +: difference-func ( func func -- func ) + [ bi - ] 2curry ; inline + +: eval ( x func -- pt ) + dupd call 2array ; inline + +: eval-inverse ( y func -- pt ) + dupd call swap 2array ; inline + +: eval3d ( x y func -- pt ) + [ 2dup ] dip call 3array ; inline diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor index 6e83a61eb3..0368dd5286 100755 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -21,17 +21,17 @@ SYMBOL: matrix : cols ( -- n ) 0 nth-row length ; : skip ( i seq quot -- n ) - over >r find-from drop r> length or ; inline + over [ find-from drop ] dip length or ; inline : first-col ( row# -- n ) #! First non-zero column 0 swap nth-row [ zero? not ] skip ; : clear-scale ( col# pivot-row i-row -- n ) - >r over r> nth dup zero? [ + [ over ] dip nth dup zero? [ 3drop 0 ] [ - >r nth dup zero? r> swap [ + [ nth dup zero? ] dip swap [ 2drop 0 ] [ swap / neg @@ -39,13 +39,13 @@ SYMBOL: matrix ] if ; : (clear-col) ( col# pivot-row i -- ) - [ [ clear-scale ] 2keep >r n*v r> v+ ] change-row ; + [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ; : rows-from ( row# -- slice ) rows dup ; : clear-col ( col# row# rows -- ) - >r nth-row r> [ >r 2dup r> (clear-col) ] each 2drop ; + [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ; : do-row ( exchange-with row# -- ) [ exchange-rows ] keep @@ -53,7 +53,7 @@ SYMBOL: matrix dup 1+ rows-from clear-col ; : find-row ( row# quot -- i elt ) - >r rows-from r> find ; inline + [ rows-from ] dip find ; inline : pivot-row ( col# row# -- n ) [ dupd nth-row nth zero? not ] find-row 2nip ; @@ -61,7 +61,7 @@ SYMBOL: matrix : (echelon) ( col# row# -- ) over cols < over rows < and [ 2dup pivot-row [ over do-row 1+ ] when* - >r 1+ r> (echelon) + [ 1+ ] dip (echelon) ] [ 2drop ] if ; @@ -86,10 +86,10 @@ SYMBOL: matrix ] with-matrix ; : basis-vector ( row col# -- ) - >r clone r> + [ clone ] dip [ swap nth neg recip ] 2keep [ 0 spin set-nth ] 2keep - >r n*v r> + [ n*v ] dip matrix get set-nth ; : nullspace ( matrix -- seq ) diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor index 529ddb083a..0088b17372 100755 --- a/extra/math/matrices/matrices.factor +++ b/extra/math/matrices/matrices.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences math math.functions -math.vectors math.order ; +USING: arrays kernel math math.order math.vectors sequences ; IN: math.matrices ! Matrices @@ -29,8 +28,8 @@ IN: math.matrices : m.v ( m v -- v ) [ v. ] curry map ; : m. ( m m -- m ) flip [ swap m.v ] curry map ; -: mmin ( m -- n ) >r 1/0. r> [ [ min ] each ] each ; -: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ; +: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; +: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; : mnorm ( m -- n ) dup mmax abs m/n ; r 1+ r> (factor-2s) ] when ; + dup even? [ -1 shift [ 1+ ] dip (factor-2s) ] when ; : factor-2s ( n -- r s ) #! factor an integer into s * 2^r diff --git a/extra/math/newtons-method/newtons-method.factor b/extra/math/newtons-method/newtons-method.factor index 269eae2538..4b53b1222d 100644 --- a/extra/math/newtons-method/newtons-method.factor +++ b/extra/math/newtons-method/newtons-method.factor @@ -1,9 +1,10 @@ -! Copyright © 2008 Reginald Keith Ford II +! Copyright (c) 2008 Reginald Keith Ford II. ! See http://factorcode.org/license.txt for BSD license. -! Newton's Method of approximating roots USING: kernel math math.derivatives ; IN: math.newtons-method +! Newton's method of approximating roots + Date: Fri, 7 Nov 2008 01:25:18 -0500 Subject: [PATCH 03/83] Rerun ave-time of PE #43 after constant space change --- extra/project-euler/043/043.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index 37118b88a3..3b330dbe4b 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -59,7 +59,7 @@ PRIVATE> ] reduce-permutations ; ! [ euler043 ] time -! 104526 ms run / 42735 ms GC time +! 60280 ms run / 59 ms GC time ! ALTERNATE SOLUTIONS From 2fafae50132d4682ada799a9314b59a100272572 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 7 Nov 2008 01:35:17 -0500 Subject: [PATCH 04/83] Refactor and clean up of math.fft --- extra/math/fft/fft.factor | 43 ++++++++++++++++++++++++++++++--------- 1 file changed, 33 insertions(+), 10 deletions(-) diff --git a/extra/math/fft/fft.factor b/extra/math/fft/fft.factor index b82ecb6b2c..7dfdc0bcfc 100644 --- a/extra/math/fft/fft.factor +++ b/extra/math/fft/fft.factor @@ -1,15 +1,38 @@ -! Fast Fourier Transform, copyright (C) 2007 Hans Schmid -! http://dressguardmeister.blogspot.com/2007/01/fft.html -USING: arrays sequences math math.vectors math.constants -math.functions kernel splitting grouping columns ; +! Copyright (c) 2007 Hans Schmid. +! See http://factorcode.org/license.txt for BSD license. +USING: columns grouping kernel math math.constants math.functions math.vectors + sequences ; IN: math.fft +! Fast Fourier Transform + + + +DEFER: fft + +: two ( seq -- seq ) + fft 2 v/n dup append ; + + ; : odd ( seq -- seq ) 2 group 1 ; -DEFER: fft -: two ( seq -- seq ) fft 2 v/n dup append ; -: omega ( n -- n' ) recip -2 pi i* * * exp ; -: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ; -: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ; -: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ; + +: (fft) ( seq -- seq ) + [ odd two twiddle ] [ even two ] bi v+ ; + +PRIVATE> + +: fft ( seq -- seq ) + dup length 1 = [ (fft) ] unless ; + From 380cd2d3b061e2e378713215b894ae2156da04cd Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 7 Nov 2008 01:36:02 -0500 Subject: [PATCH 05/83] Clean up of math.finance --- extra/math/finance/finance.factor | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor index db300a3b70..f006e6aee7 100644 --- a/extra/math/finance/finance.factor +++ b/extra/math/finance/finance.factor @@ -1,18 +1,16 @@ -! Copyright (C) 2008 John Benediktsson -! See http://factorcode.org/license.txt for BSD license - +! Copyright (C) 2008 John Benediktsson. +! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel grouping sequences shuffle math math.functions math.statistics math.vectors ; - IN: math.finance @@ -26,6 +24,5 @@ PRIVATE> rot dup ema [ swap ema ] dip v- ; : momentum ( seq n -- newseq ) - 2dup tail-slice -rot swap [ length ] keep - [ - neg ] dip swap head-slice v- ; + [ tail-slice ] 2keep [ dup length ] dip - head-slice v- ; From 6182a161dba6eead4fa91a11cafcbba1732a27d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Nov 2008 22:03:27 -0600 Subject: [PATCH 06/83] support reading 8bit bitmaps, 4bit is blocking on bit-streams --- extra/graphics/bitmap/bitmap.factor | 34 +++++++++++++++++++---------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 651c5f7ca1..4d83300934 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -5,7 +5,7 @@ USING: alien arrays byte-arrays combinators summary io.backend graphics.viewer io io.binary io.files kernel libc math math.functions namespaces opengl opengl.gl prettyprint sequences strings ui ui.gadgets.panes io.encodings.binary -accessors ; +accessors grouping ; IN: graphics.bitmap ! Currently can only handle 24bit bitmaps. @@ -23,16 +23,25 @@ TUPLE: bitmap magic size reserved offset header-length width swap [ >>array ] [ >>color-index ] bi 24 >>bit-count ; -: raw-bitmap>string ( str n -- str ) +: 8bit>array ( bitmap -- array ) + [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-index>> >array ] bi [ swap nth ] with map concat ; + +: 4bit>array ( bitmap -- array ) + [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-index>> >array ] bi [ swap nth ] with map concat ; + +: raw-bitmap>array ( bitmap -- array ) + dup bit-count>> { { 32 [ "32bit" throw ] } - { 24 [ ] } + { 24 [ color-index>> ] } { 16 [ "16bit" throw ] } - { 8 [ "8bit" throw ] } - { 4 [ "4bit" throw ] } + { 8 [ 8bit>array ] } + { 4 [ 4bit>array ] } { 2 [ "2bit" throw ] } { 1 [ "1bit" throw ] } - } case ; + } case >byte-array ; ERROR: bitmap-magic ; @@ -72,13 +81,12 @@ M: bitmap-magic summary : load-bitmap ( path -- bitmap ) normalize-path binary [ - T{ bitmap } clone - dup parse-file-header - dup parse-bitmap-header - dup parse-bitmap + bitmap new + dup parse-file-header + dup parse-bitmap-header + dup parse-bitmap ] with-file-reader - dup color-index>> over bit-count>> - raw-bitmap>string >byte-array >>array ; + dup raw-bitmap>array >>array ; : save-bitmap ( bitmap path -- ) binary [ @@ -118,6 +126,8 @@ M: bitmap draw-image ( bitmap -- ) bit-count>> { ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } } case ] keep array>> glDrawPixels ; From 23ec6ef1228d6778248f6b217514b83c873c9235 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 8 Nov 2008 15:30:28 -0500 Subject: [PATCH 07/83] Minor stack shuffling changes --- extra/math/erato/erato.factor | 2 +- extra/math/finance/finance.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 894905e405..7f9262380c 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -15,7 +15,7 @@ TUPLE: erato limit bits latest ; [ ind ] [ bits>> ] bi* nth ; inline : indices ( n erato -- range ) - limit>> ind over 3 * ind swap rot ; + limit>> ind over 3 * ind spin ; : mark-multiples ( n erato -- ) 2dup [ sq ] [ limit>> ] bi* <= [ diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor index f006e6aee7..e02f4be624 100644 --- a/extra/math/finance/finance.factor +++ b/extra/math/finance/finance.factor @@ -7,7 +7,7 @@ IN: math.finance : ema ( seq n -- newseq ) - a swap unclip [ [ dup ] 2dip swap rot weighted ] accumulate 2nip ; + a swap unclip [ [ dup ] 2dip spin weighted ] accumulate 2nip ; : sma ( seq n -- newseq ) clump [ mean ] map ; From 798139f2e7ad63e026d2a8d4b784aaa28607db23 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 8 Nov 2008 16:03:52 -0500 Subject: [PATCH 08/83] Minor polynomials cleanup, could use refactoring --- extra/math/polynomials/polynomials.factor | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index 51512ca2e3..47226114d0 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences vectors math math.vectors -namespaces make shuffle splitting sequences.lib math.order ; +USING: arrays kernel make math math.order math.vectors sequences shuffle + splitting vectors ; IN: math.polynomials ! Polynomials are vectors with the highest powers on the right: @@ -13,14 +13,16 @@ IN: math.polynomials 1 [ * ] accumulate nip ; + : p= ( p p -- ? ) pextend = ; : ptrim ( p -- p ) @@ -33,14 +35,14 @@ PRIVATE> ! convolution : pextend-conv ( p p -- p p ) - #! extend to: p_m + p_n - 1 + #! extend to: p_m + p_n - 1 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ; : p* ( p p -- p ) #! Multiply two polynomials. 2unempty pextend-conv dup length [ over length pick pick [ * ] 2map sum ] map 2nip reverse ; - + : p-sq ( p -- p-sq ) dup p* ; @@ -72,7 +74,7 @@ PRIVATE> dup V{ 0 } clone p= [ drop nip ] [ - tuck p/mod >r pick p* swap >r swapd p- r> r> (pgcd) + tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd) ] if ; : pgcd ( p p -- p q ) From 774cb858d5c9fd8f747b97c6ae3b67d348e3de59 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 8 Nov 2008 16:34:39 -0500 Subject: [PATCH 09/83] Small updates to math.primes --- extra/math/primes/factors/factors.factor | 11 ++++++----- extra/math/primes/primes.factor | 10 ++++------ 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index 059bd67c18..80c93f2ae0 100644 --- a/extra/math/primes/factors/factors.factor +++ b/extra/math/primes/factors/factors.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel lists math math.primes namespaces make -sequences ; +USING: arrays kernel lists make math math.primes sequences ; IN: math.primes.factors [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ; + dup 1 > [ + swap uncons swap [ pick call ] dip swap (factors) + ] [ 3drop ] if ; : (decompose) ( n quot -- seq ) [ lprimes rot (factors) ] { } make ; @@ -38,5 +39,5 @@ PRIVATE> dup 2 < [ drop 0 ] [ - dup unique-factors dup 1 [ 1- * ] reduce swap product / * + dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ] if ; foldable diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index feb60c555d..820d5b6c4a 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel lists.lazy math math.functions math.miller-rabin - math.order math.primes.list math.ranges sequences sorting - binary-search ; +USING: binary-search combinators kernel lists.lazy math math.functions + math.miller-rabin math.primes.list sequences ; IN: math.primes } cond ; foldable : primes-between ( low high -- seq ) - primes-upto - [ 1- next-prime ] dip - [ natural-search drop ] keep [ length ] keep ; foldable + primes-upto [ 1- next-prime ] dip + [ natural-search drop ] [ length ] [ ] tri ; foldable : coprime? ( a b -- ? ) gcd nip 1 = ; foldable From 326ce8c71b72348d7b38014a49eab0c499c49a08 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 8 Nov 2008 16:47:58 -0500 Subject: [PATCH 10/83] Update >r r> to dip in math.quaternions --- extra/math/quaternions/quaternions.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor index 65f18d3568..ffc0fcc9f7 100755 --- a/extra/math/quaternions/quaternions.factor +++ b/extra/math/quaternions/quaternions.factor @@ -16,9 +16,9 @@ IN: math.quaternions : 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline -: q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline +: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline -: q*b ( u v -- b ) 2q >r ** swap r> * + ; inline +: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline PRIVATE> @@ -51,12 +51,12 @@ PRIVATE> : v>q ( v -- q ) #! Turn a 3-vector into a quaternion with real part 0. - first3 rect> >r 0 swap rect> r> 2array ; + first3 rect> [ 0 swap rect> ] dip 2array ; : q>v ( q -- v ) #! Get the vector part of a quaternion, discarding the real #! part. - first2 >r imaginary-part r> >rect 3array ; + first2 [ imaginary-part ] dip >rect 3array ; ! Zero : q0 { 0 0 } ; @@ -71,7 +71,7 @@ PRIVATE> ! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html : (euler) ( theta unit -- q ) - >r -0.5 * dup cos c>q swap sin r> n*v v- ; + [ -0.5 * dup cos c>q swap sin ] dip n*v v- ; : euler ( phi theta psi -- q ) [ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ; From 57242951b9ec01c676c673b0eabf0b63a760813d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Nov 2008 19:33:15 -0600 Subject: [PATCH 11/83] Better error reporting in FROM: and RENAME: words --- basis/fry/fry.factor | 2 +- basis/qualified/qualified-docs.factor | 11 +++++++++ basis/qualified/qualified-tests.factor | 31 +++++++++++++++++--------- basis/qualified/qualified.factor | 30 ++++++++++++------------- core/parser/parser-docs.factor | 2 +- core/parser/parser.factor | 4 ++-- 6 files changed, 50 insertions(+), 30 deletions(-) diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index 395d5c3caf..87c59e18a0 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences combinators parser splitting math -quotations arrays make qualified words ; +quotations arrays make words ; IN: fry : _ ( -- * ) "Only valid inside a fry" throw ; diff --git a/basis/qualified/qualified-docs.factor b/basis/qualified/qualified-docs.factor index d62f696a74..067d221d2f 100644 --- a/basis/qualified/qualified-docs.factor +++ b/basis/qualified/qualified-docs.factor @@ -32,3 +32,14 @@ HELP: RENAME: "RENAME: + math => -" "2 3 - ! => 5" } } ; +ARTICLE: "qualified" "Qualified word lookup" +"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "." +$nl +"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file." +{ $subsection POSTPONE: QUALIFIED: } +{ $subsection POSTPONE: QUALIFIED-WITH: } +{ $subsection POSTPONE: FROM: } +{ $subsection POSTPONE: EXCLUDE: } +{ $subsection POSTPONE: RENAME: } ; + +ABOUT: "qualified" diff --git a/basis/qualified/qualified-tests.factor b/basis/qualified/qualified-tests.factor index 8f67ddf730..78efec4861 100644 --- a/basis/qualified/qualified-tests.factor +++ b/basis/qualified/qualified-tests.factor @@ -1,24 +1,33 @@ -USING: tools.test qualified ; -IN: foo +USING: tools.test qualified eval accessors parser ; +IN: qualified.tests.foo : x 1 ; -IN: bar +: y 5 ; +IN: qualified.tests.bar : x 2 ; -IN: baz +: y 4 ; +IN: qualified.tests.baz : x 3 ; -QUALIFIED: foo -QUALIFIED: bar -[ 1 2 3 ] [ foo:x bar:x x ] unit-test +QUALIFIED: qualified.tests.foo +QUALIFIED: qualified.tests.bar +[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test -QUALIFIED-WITH: bar p +QUALIFIED-WITH: qualified.tests.bar p [ 2 ] [ p:x ] unit-test -RENAME: x baz => y +RENAME: x qualified.tests.baz => y [ 3 ] [ y ] unit-test -FROM: baz => x ; +FROM: qualified.tests.baz => x ; [ 3 ] [ x ] unit-test +[ 3 ] [ y ] unit-test -EXCLUDE: bar => x ; +EXCLUDE: qualified.tests.bar => x ; [ 3 ] [ x ] unit-test +[ 4 ] [ y ] unit-test +[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ] +[ error>> no-word-error? ] must-fail-with + +[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ] +[ error>> no-word-error? ] must-fail-with diff --git a/basis/qualified/qualified.factor b/basis/qualified/qualified.factor index d636cc0152..d387ef4b0e 100644 --- a/basis/qualified/qualified.factor +++ b/basis/qualified/qualified.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences assocs hashtables parser lexer -vocabs words namespaces vocabs.loader debugger sets ; +vocabs words namespaces vocabs.loader debugger sets fry ; IN: qualified : define-qualified ( vocab-name prefix-name -- ) [ load-vocab vocab-words ] [ CHAR: : suffix ] bi* - [ -rot >r append r> ] curry assoc-map + '[ [ [ _ ] dip append ] dip ] assoc-map use get push ; : QUALIFIED: @@ -19,27 +19,27 @@ IN: qualified : expect=> ( -- ) scan "=>" assert= ; -: partial-vocab ( words name -- assoc ) - dupd [ - lookup [ "No such word: " swap append throw ] unless* - ] curry map zip ; - -: partial-vocab-ignoring ( words name -- assoc ) - [ load-vocab vocab-words keys swap diff ] keep partial-vocab ; - -: EXCLUDE: - #! Syntax: EXCLUDE: vocab => words ... ; - scan expect=> - ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing +: partial-vocab ( words vocab -- assoc ) + '[ dup _ lookup [ no-word-error ] unless* ] + { } map>assoc ; : FROM: #! Syntax: FROM: vocab => words... ; scan dup load-vocab drop expect=> ";" parse-tokens swap partial-vocab use get push ; parsing +: partial-vocab-excluding ( words vocab -- assoc ) + [ load-vocab vocab-words keys swap diff ] keep partial-vocab ; + +: EXCLUDE: + #! Syntax: EXCLUDE: vocab => words ... ; + scan expect=> + ";" parse-tokens swap partial-vocab-excluding use get push ; parsing + : RENAME: #! Syntax: RENAME: word vocab => newname - scan scan dup load-vocab drop lookup [ "No such word" throw ] unless* + scan scan dup load-vocab drop + dupd lookup [ ] [ no-word-error ] ?if expect=> scan associate use get push ; parsing diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 1d8d1f0714..d33f5cd6d9 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -69,7 +69,7 @@ $nl { $subsection POSTPONE: PRIVATE> } { $subsection "vocabulary-search-errors" } { $subsection "vocabulary-search-shadow" } -{ $see-also "words" } ; +{ $see-also "words" "qualified" } ; ARTICLE: "reading-ahead" "Reading ahead" "Parsing words can consume input:" diff --git a/core/parser/parser.factor b/core/parser/parser.factor index a86715b073..ed8fc4510b 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -71,10 +71,10 @@ ERROR: no-current-vocab ; ] keep ] { } map>assoc ; -TUPLE: no-word-error name ; +ERROR: no-word-error name ; : no-word ( name -- newword ) - dup no-word-error boa + dup \ no-word-error boa swap words-named [ forward-reference? not ] filter word-restarts throw-restarts dup vocabulary>> (use+) ; From 359fb6e5183f781dd0f76c0e0e85ac35de08e43c Mon Sep 17 00:00:00 2001 From: unknown Date: Sat, 8 Nov 2008 20:32:23 -0600 Subject: [PATCH 12/83] VM fixes for Win64 calling convention --- vm/cpu-x86.32.S | 4 ++++ vm/cpu-x86.64.S | 6 ++++++ vm/cpu-x86.S | 17 +++++++++-------- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index e0e674a7e2..eec850dc9e 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -10,14 +10,18 @@ and the callstack top is passed in EDX */ #define DS_REG %esi #define RETURN_REG %eax +#define NV_TEMP_REG %rbx + #define CELL_SIZE 4 #define STACK_PADDING 12 #define PUSH_NONVOLATILE \ push %ebx ; \ + push %ebp ; \ push %ebp #define POP_NONVOLATILE \ + pop %ebp ; \ pop %ebp ; \ pop %ebx diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 15a4eb8da3..c981095d62 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -7,6 +7,8 @@ #define CELL_SIZE 8 #define STACK_PADDING 56 +#define NV_TEMP_REG %rbp + #ifdef WINDOWS #define ARG0 %rcx @@ -20,9 +22,11 @@ push %rdi ; \ push %rsi ; \ push %rbx ; \ + push %rbp ; \ push %rbp #define POP_NONVOLATILE \ + pop %rbp ; \ pop %rbp ; \ pop %rbx ; \ pop %rsi ; \ @@ -41,9 +45,11 @@ push %rbx ; \ push %rbp ; \ push %r12 ; \ + push %r13 ; \ push %r13 #define POP_NONVOLATILE \ + pop %r13 ; \ pop %r13 ; \ pop %r12 ; \ pop %rbp ; \ diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 3d6cacdebd..1857fb0ed8 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -1,20 +1,21 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE - push ARG0 - - /* Save stack pointer */ - lea -CELL_SIZE(STACK_REG),ARG0 + mov ARG0,NV_TEMP_REG /* Create register shadow area for Win64 */ - sub $32,STACK_REG + sub $32,STACK_REG + + /* Save stack pointer */ + lea -CELL_SIZE(STACK_REG),ARG0 call MANGLE(save_callstack_bottom) - add $32,STACK_REG /* Call quot-xt */ - mov (STACK_REG),ARG0 + mov NV_TEMP_REG,ARG0 call *QUOT_XT_OFFSET(ARG0) - pop ARG0 + /* Tear down register shadow area */ + add $32,STACK_REG + POP_NONVOLATILE ret From b9ee92e484456d2103c6f5b3f9fa13ed36746774 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Nov 2008 20:36:05 -0600 Subject: [PATCH 13/83] factor.sh fixes --- build-support/factor.sh | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 7fbb54a568..bd234afb5f 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -271,17 +271,21 @@ check_os_arch_word() { set_build_info() { check_os_arch_word - MAKE_TARGET=$OS-$ARCH-$WORD if [[ $OS == macosx && $ARCH == ppc ]] ; then MAKE_IMAGE_TARGET=macosx-ppc + MAKE_TARGET=macosx-ppc elif [[ $OS == linux && $ARCH == ppc ]] ; then MAKE_IMAGE_TARGET=linux-ppc + MAKE_TARGET=linux-ppc elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=winnt-x86.64 + MAKE_TARGET=winnt-x86-64 elif [[ $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=unix-x86.64 - else + MAKE_TARGET=$OS-x86-64 + else MAKE_IMAGE_TARGET=$ARCH.$WORD + MAKE_TARGET=$OS-$ARCH-$WORD fi BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image } From 65dea0aa26e233cddd29af5494ab085ea900c2fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Nov 2008 20:36:14 -0600 Subject: [PATCH 14/83] PowerPC backend fixes --- basis/cpu/ppc/linux/linux.factor | 13 +++++++------ basis/cpu/ppc/macosx/macosx.factor | 13 +++++++------ basis/cpu/ppc/ppc.factor | 13 +++++++++---- 3 files changed, 23 insertions(+), 16 deletions(-) diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor index d92709a399..6f21aa74d5 100644 --- a/basis/cpu/ppc/linux/linux.factor +++ b/basis/cpu/ppc/linux/linux.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ; +USING: accessors system kernel layouts +alien.c-types cpu.architecture cpu.ppc ; IN: cpu.ppc.linux << @@ -8,12 +9,12 @@ t "longlong" c-type (>>stack-align?) t "ulonglong" c-type (>>stack-align?) >> -M: linux reserved-area-size 2 ; +M: linux reserved-area-size 2 cells ; -M: linux lr-save 1 ; +M: linux lr-save 1 cells ; -M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ; +M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ; -M: ppc value-structs? drop f ; +M: ppc value-structs? f ; -M: ppc fp-shadows-int? drop f ; +M: ppc fp-shadows-int? f ; diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor index 1e0a6caca0..619b82a04b 100644 --- a/basis/cpu/ppc/macosx/macosx.factor +++ b/basis/cpu/ppc/macosx/macosx.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ; +USING: accessors system kernel layouts +alien.c-types cpu.architecture cpu.ppc ; IN: cpu.ppc.macosx << @@ -9,12 +10,12 @@ IN: cpu.ppc.macosx 4 "double" c-type (>>align) >> -M: macosx reserved-area-size 6 ; +M: macosx reserved-area-size 6 cells ; -M: macosx lr-save 2 ; +M: macosx lr-save 2 cells ; -M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; +M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; -M: ppc value-structs? drop t ; +M: ppc value-structs? t ; -M: ppc fp-shadows-int? drop t ; +M: ppc fp-shadows-int? t ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index d2d1e26396..2be46d15ee 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -349,12 +349,17 @@ M: ppc %gc "end" resolve-label ; M: ppc %prologue ( n -- ) - 0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this + #! We use a volatile register (r11) here for scratch. Because + #! callback bodies have a prologue too, we cannot assume + #! that c_to_factor saved all non-volatile registers, so + #! we have to respect the C calling convention. Also, we + #! cannot touch any param-regs either. + 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this 0 MFLR 1 1 pick neg ADDI - scratch-reg 1 pick xt-save STW - dup scratch-reg LI - scratch-reg 1 pick next-save STW + 11 1 pick xt-save STW + dup 11 LI + 11 1 pick next-save STW 0 1 rot lr-save + STW ; M: ppc %epilogue ( n -- ) From fdbea06e279f71892ecf2354790121d5cf8da559 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Nov 2008 20:40:09 -0600 Subject: [PATCH 15/83] Fix compile warning --- vm/callstack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/callstack.c b/vm/callstack.c index c9466bbbb2..b7e99b418c 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -117,7 +117,7 @@ CELL frame_executing(F_STACK_FRAME *frame) F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) { if(frame->size == 0) - critical_error("Stack frame has zero size",frame); + critical_error("Stack frame has zero size",(CELL)frame); return (F_STACK_FRAME *)((CELL)frame - frame->size); } From abc3915387c145215dd50f8923796c71c46fd2b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Nov 2008 21:06:51 -0600 Subject: [PATCH 16/83] Fix x86-32 VM compilation; was using a 64-bit reg on accident --- vm/cpu-x86.32.S | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index eec850dc9e..6ddbd52da2 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -10,7 +10,7 @@ and the callstack top is passed in EDX */ #define DS_REG %esi #define RETURN_REG %eax -#define NV_TEMP_REG %rbx +#define NV_TEMP_REG %ebx #define CELL_SIZE 4 #define STACK_PADDING 12 From f7fe84e5634a4f2c05b019479dfe072a8bb9f457 Mon Sep 17 00:00:00 2001 From: unknown Date: Sat, 8 Nov 2008 21:40:47 -0600 Subject: [PATCH 17/83] Working on Win64 FFI --- basis/compiler/codegen/codegen.factor | 25 ++++++--- basis/cpu/architecture/architecture.factor | 10 +++- basis/cpu/ppc/linux/linux.factor | 8 ++- basis/cpu/ppc/macosx/macosx.factor | 8 ++- basis/cpu/x86/32/32.factor | 6 +++ basis/cpu/x86/64/64.factor | 63 ++++++---------------- basis/cpu/x86/64/unix/unix.factor | 40 ++++++++++++++ basis/cpu/x86/64/winnt/winnt.factor | 13 ++++- basis/cpu/x86/x86.factor | 12 ++--- 9 files changed, 117 insertions(+), 68 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index cab86dcb54..35d4d59253 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces make math math.parser sequences accessors +USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays sets threads libc continuations.private @@ -234,13 +234,26 @@ M: float-regs reg-class-variable drop float-regs ; GENERIC: inc-reg-class ( register-class -- ) -M: reg-class inc-reg-class - dup reg-class-variable inc - fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; +: ?dummy-stack-params ( reg-class -- ) + dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ; + +: ?dummy-int-params ( reg-class -- ) + dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ; + +: ?dummy-fp-params ( reg-class -- ) + drop dummy-fp-params? [ float-regs inc ] when ; + +M: int-regs inc-reg-class + [ reg-class-variable inc ] + [ ?dummy-stack-params ] + [ ?dummy-fp-params ] + tri ; M: float-regs inc-reg-class - dup call-next-method - fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; + [ reg-class-variable inc ] + [ ?dummy-stack-params ] + [ ?dummy-int-params ] + tri ; GENERIC: reg-class-full? ( class -- ? ) diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index e4fa9419f0..b0b5b048d9 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -146,8 +146,14 @@ HOOK: struct-small-enough? cpu ( heap-size -- ? ) ! Do we pass value structs by value or hidden reference? HOOK: value-structs? cpu ( -- ? ) -! If t, fp parameters are shadowed by dummy int parameters -HOOK: fp-shadows-int? cpu ( -- ? ) +! If t, all parameters are shadowed by dummy stack parameters +HOOK: dummy-stack-params? cpu ( -- ? ) + +! If t, all FP parameters are shadowed by dummy int parameters +HOOK: dummy-int-params? cpu ( -- ? ) + +! If t, all int parameters are shadowed by dummy FP parameters +HOOK: dummy-fp-params? cpu ( -- ? ) HOOK: %prepare-unbox cpu ( -- ) diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor index d92709a399..c6649c7ad2 100644 --- a/basis/cpu/ppc/linux/linux.factor +++ b/basis/cpu/ppc/linux/linux.factor @@ -14,6 +14,10 @@ M: linux lr-save 1 ; M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ; -M: ppc value-structs? drop f ; +M: ppc value-structs? f ; -M: ppc fp-shadows-int? drop f ; +M: ppc dummy-stack-params? f ; + +M: ppc dummy-int-params? f ; + +M: ppc dummy-fp-params? f ; diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor index 1e0a6caca0..bb607d0e44 100644 --- a/basis/cpu/ppc/macosx/macosx.factor +++ b/basis/cpu/ppc/macosx/macosx.factor @@ -15,6 +15,10 @@ M: macosx lr-save 2 ; M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; -M: ppc value-structs? drop t ; +M: ppc value-structs? t ; -M: ppc fp-shadows-int? drop t ; +M: ppc dummy-stack-params? t ; + +M: ppc dummy-int-params? t ; + +M: ppc dummy-fp-params? f ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 82fa7a012e..f26d76551a 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -274,6 +274,12 @@ M: x86.32 %callback-return ( n -- ) [ drop 0 ] } cond RET ; +M: x86.32 dummy-stack-params? f ; + +M: x86.32 dummy-int-params? f ; + +M: x86.32 dummy-fp-params? f ; + os windows? [ cell "longlong" c-type (>>align) cell "ulonglong" c-type (>>align) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index d45dd098b8..0d20660021 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -26,6 +26,7 @@ M: x86.64 temp-reg-2 RCX ; : param-reg-1 int-regs param-regs first ; inline : param-reg-2 int-regs param-regs second ; inline +: param-reg-3 int-regs param-regs third ; inline M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; @@ -40,13 +41,13 @@ M: x86.64 %prologue ( n -- ) M: stack-params %load-param-reg drop - >r R11 swap stack@ MOV - r> stack@ R11 MOV ; + >r R11 swap param@ MOV + r> param@ R11 MOV ; M: stack-params %save-param-reg drop R11 swap next-stack@ MOV - stack@ R11 MOV ; + param@ R11 MOV ; : with-return-regs ( quot -- ) [ @@ -55,37 +56,6 @@ M: stack-params %save-param-reg call ] with-scope ; inline -! The ABI for passing structs by value is pretty messed up -<< "void*" c-type clone "__stack_value" define-primitive-type -stack-params "__stack_value" c-type (>>reg-class) >> - -: struct-types&offset ( struct-type -- pairs ) - fields>> [ - [ type>> ] [ offset>> ] bi 2array - ] map ; - -: split-struct ( pairs -- seq ) - [ - [ 8 mod zero? [ t , ] when , ] assoc-each - ] { } make { t } split harvest ; - -: flatten-small-struct ( c-type -- seq ) - struct-types&offset split-struct [ - [ c-type c-type-reg-class ] map - int-regs swap member? "void*" "double" ? c-type - ] map ; - -: flatten-large-struct ( c-type -- seq ) - heap-size cell align - cell /i "__stack_value" c-type ; - -M: struct-type flatten-value-type ( type -- seq ) - dup heap-size 16 > [ - flatten-large-struct - ] [ - flatten-small-struct - ] if ; - M: x86.64 %prepare-unbox ( -- ) ! First parameter is top of stack param-reg-1 R14 [] MOV @@ -102,7 +72,7 @@ M: x86.64 %unbox-long-long ( n func -- ) : %unbox-struct-field ( c-type i -- ) ! Alien must be in param-reg-1. - param-reg-1 swap cells [+] swap reg-class>> { + R11 swap cells [+] swap reg-class>> { { int-regs [ int-regs get pop swap MOV ] } { double-float-regs [ float-regs get pop swap MOVSD ] } } case ; @@ -110,20 +80,20 @@ M: x86.64 %unbox-long-long ( n func -- ) M: x86.64 %unbox-small-struct ( c-type -- ) ! Alien must be in param-reg-1. "alien_offset" f %alien-invoke - ! Move alien_offset() return value to param-reg-1 so that we don't + ! Move alien_offset() return value to R11 so that we don't ! clobber it. - param-reg-1 RAX MOV + R11 RAX MOV [ - flatten-small-struct [ %unbox-struct-field ] each-index + flatten-value-type [ %unbox-struct-field ] each-index ] with-return-regs ; M: x86.64 %unbox-large-struct ( n c-type -- ) ! Source is in param-reg-1 heap-size ! Load destination address - param-reg-2 rot stack@ LEA + param-reg-2 rot param@ LEA ! Load structure size - RDX swap MOV + param-reg-3 swap MOV ! Copy the struct to the C stack "to_value_struct" f %alien-invoke ; @@ -142,10 +112,7 @@ M: x86.64 %box ( n reg-class func -- ) M: x86.64 %box-long-long ( n func -- ) int-regs swap %box ; -M: x86.64 struct-small-enough? ( size -- ? ) - heap-size 2 cells <= ; - -: box-struct-field@ ( i -- operand ) 1+ cells stack@ ; +: box-struct-field@ ( i -- operand ) 1+ cells param@ ; : %box-struct-field ( c-type i -- ) box-struct-field@ swap reg-class>> { @@ -156,15 +123,15 @@ M: x86.64 struct-small-enough? ( size -- ? ) M: x86.64 %box-small-struct ( c-type -- ) #! Box a <= 16-byte struct. [ - [ flatten-small-struct [ %box-struct-field ] each-index ] - [ RDX swap heap-size MOV ] bi + [ flatten-value-type [ %box-struct-field ] each-index ] + [ param-reg-3 swap heap-size MOV ] bi param-reg-1 0 box-struct-field@ MOV param-reg-2 1 box-struct-field@ MOV "box_small_struct" f %alien-invoke ] with-return-regs ; : struct-return@ ( n -- operand ) - [ stack-frame get params>> ] unless* stack@ ; + [ stack-frame get params>> ] unless* param@ ; M: x86.64 %box-large-struct ( n c-type -- ) ! Struct size is parameter 2 @@ -178,7 +145,7 @@ M: x86.64 %prepare-box-struct ( -- ) ! Compute target address for value struct return RAX f struct-return@ LEA ! Store it as the first parameter - 0 stack@ RAX MOV ; + 0 param@ RAX MOV ; M: x86.64 %prepare-var-args RAX RAX XOR ; diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index abbd0cf21b..1a65132fab 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -10,3 +10,43 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; M: x86.64 reserved-area-size 0 ; + +! The ABI for passing structs by value is pretty messed up +<< "void*" c-type clone "__stack_value" define-primitive-type +stack-params "__stack_value" c-type (>>reg-class) >> + +: struct-types&offset ( struct-type -- pairs ) + fields>> [ + [ type>> ] [ offset>> ] bi 2array + ] map ; + +: split-struct ( pairs -- seq ) + [ + [ 8 mod zero? [ t , ] when , ] assoc-each + ] { } make { t } split harvest ; + +: flatten-small-struct ( c-type -- seq ) + struct-types&offset split-struct [ + [ c-type c-type-reg-class ] map + int-regs swap member? "void*" "double" ? c-type + ] map ; + +: flatten-large-struct ( c-type -- seq ) + heap-size cell align + cell /i "__stack_value" c-type ; + +M: struct-type flatten-value-type ( type -- seq ) + dup heap-size 16 > [ + flatten-large-struct + ] [ + flatten-small-struct + ] if ; + +M: x86.64 struct-small-enough? ( size -- ? ) + heap-size 2 cells <= ; + +M: x86.64 dummy-stack-params? f ; + +M: x86.64 dummy-int-params? f ; + +M: x86.64 dummy-fp-params? f ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index d4c092f63d..0124c40877 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel layouts system alien.c-types compiler.cfg.registers -cpu.architecture cpu.x86.assembler cpu.x86 ; +USING: kernel layouts system math alien.c-types +compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ; IN: cpu.x86.64.winnt M: int-regs param-regs drop { RCX RDX R8 R9 } ; @@ -10,6 +10,15 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ; M: x86.64 reserved-area-size 4 cells ; +M: x86.64 struct-small-enough? ( size -- ? ) + heap-size cell <= ; + +M: x86.64 dummy-stack-params? f ; + +M: x86.64 dummy-int-params? t ; + +M: x86.64 dummy-fp-params? t ; + << "longlong" "ptrdiff_t" typedef "int" "long" typedef diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 55675a5e42..4f72fe45e1 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -467,6 +467,8 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- ) : stack@ ( n -- op ) stack-reg swap [+] ; +: param@ ( n -- op ) reserved-area-size + stack@ ; + : spill-integer-base ( stack-frame -- n ) [ params>> ] [ return>> ] bi + reserved-area-size + ; @@ -493,16 +495,16 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ; -M: int-regs %save-param-reg drop >r stack@ r> MOV ; -M: int-regs %load-param-reg drop swap stack@ MOV ; +M: int-regs %save-param-reg drop >r param@ r> MOV ; +M: int-regs %load-param-reg drop swap param@ MOV ; GENERIC: MOVSS/D ( dst src reg-class -- ) M: single-float-regs MOVSS/D drop MOVSS ; M: double-float-regs MOVSS/D drop MOVSD ; -M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; -M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; +M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ; +M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ; GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( n reg-class -- ) @@ -518,8 +520,6 @@ M: x86 %prepare-alien-invoke temp-reg-1 2 cells [+] ds-reg MOV temp-reg-1 3 cells [+] rs-reg MOV ; -M: x86 fp-shadows-int? ( -- ? ) f ; - M: x86 value-structs? t ; M: x86 small-enough? ( n -- ? ) From 28e397420d257d4fbd3896b68f72e8b6bb8da8b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Nov 2008 21:43:55 -0600 Subject: [PATCH 18/83] Fix USING: --- basis/cpu/x86/64/unix/unix.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index 1a65132fab..ddb412873a 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel layouts system compiler.cfg.registers -cpu.architecture cpu.x86.assembler cpu.x86 ; +USING: accessors arrays sequences math splitting make assocs +kernel layouts system alien.c-types alien.structs +cpu.architecture cpu.x86.assembler cpu.x86 +compiler.codegen compiler.cfg.registers ; IN: cpu.x86.64.unix M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ; From 70d7c0ca20ce976a976240e65ac97f84c32fdf09 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 9 Nov 2008 13:01:03 -0600 Subject: [PATCH 19/83] make hexdump work with byte-arrays --- extra/hexdump/hexdump-tests.factor | 3 +++ extra/hexdump/hexdump.factor | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/hexdump/hexdump-tests.factor b/extra/hexdump/hexdump-tests.factor index 7fb26e10c5..b3c03196f5 100644 --- a/extra/hexdump/hexdump-tests.factor +++ b/extra/hexdump/hexdump-tests.factor @@ -6,3 +6,6 @@ USING: hexdump kernel sequences tools.test ; [ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test + +[ + "Length: 3, 3h\n00000000h: 01 02 03 ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor index b965fb41bb..ecbc2d6169 100644 --- a/extra/hexdump/hexdump.factor +++ b/extra/hexdump/hexdump.factor @@ -21,9 +21,9 @@ IN: hexdump [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ; : >ascii ( bytes -- str ) - [ [ printable? ] keep CHAR: . ? ] map ; + [ [ printable? ] keep CHAR: . ? ] "" map-as ; -: write-hex-line ( str lineno -- ) +: write-hex-line ( bytes lineno -- ) write-offset [ >hex-digits write ] [ >ascii write ] bi nl ; PRIVATE> From f20ab6f4e8d26a7daff973d55a03b221835e5e16 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 17:16:30 -0500 Subject: [PATCH 20/83] Refactor of math.statistics --- extra/math/statistics/statistics.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/math/statistics/statistics.factor b/extra/math/statistics/statistics.factor index 8cd6d26c1c..267a95c100 100644 --- a/extra/math/statistics/statistics.factor +++ b/extra/math/statistics/statistics.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Michael Judge. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.analysis math.functions math.vectors sequences -sequences.lib sorting ; +USING: arrays kernel math math.analysis math.functions sequences sequences.lib + sorting ; IN: math.statistics : mean ( seq -- n ) @@ -19,10 +19,10 @@ IN: math.statistics : median ( seq -- n ) #! middle number if odd, avg of two middle numbers if even - natural-sort dup length dup even? [ - 1- 2 / swap [ nth ] [ [ 1+ ] dip nth ] 2bi + 2 / + natural-sort dup length even? [ + [ midpoint@ dup 1- 2array ] keep nths mean ] [ - 2 / swap nth + [ midpoint@ ] keep nth ] if ; : range ( seq -- n ) @@ -44,14 +44,14 @@ IN: math.statistics : ste ( seq -- x ) #! standard error, standard deviation / sqrt ( length of sequence ) - dup std swap length sqrt / ; + [ std ] [ length ] bi sqrt / ; : ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) ! finds sigma((xi-mean(x))(yi-mean(y)) - 0 [ [ >r pick r> swap - ] bi@ * + ] 2reduce 2nip ; + 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ; : (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) - * recip >r [ ((r)) ] keep length 1- / r> * ; + * recip [ [ ((r)) ] keep length 1- / ] dip * ; : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ; From e5c155338fe0f6cac1fa4a139dd6fb858f73c15f Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 17:23:24 -0500 Subject: [PATCH 21/83] Fix short-circuit usage in number>text --- extra/math/text/english/english.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index dfb0c00388..58dab74cdb 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -26,7 +26,7 @@ IN: math.text.english SYMBOL: and-needed? : set-conjunction ( seq -- ) - first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ; + first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ; : negative-text ( n -- str ) 0 < "Negative " "" ? ; From 429fe85f460face61d8a31fdc12d001e950249c9 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 9 Nov 2008 17:27:39 -0600 Subject: [PATCH 22/83] Fix compile error --- basis/io/windows/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 basis/io/windows/files/files.factor diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor old mode 100644 new mode 100755 index 3fb8029ee7..3952299543 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -276,7 +276,7 @@ M: winnt file-system-info ( path -- file-system-info ) swap >>type swap >>mount-point ; -: find-first-volume ( word -- string handle ) +: find-first-volume ( -- string handle ) MAX_PATH 1+ dup length dupd FindFirstVolume dup win32-error=0/f From 2bf9a55cead31028ef311b3faf066511b60792ea Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 9 Nov 2008 17:27:51 -0600 Subject: [PATCH 23/83] Fix Windows deployment --- basis/tools/deploy/windows/windows.factor | 26 +++++++++++------------ 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index ad1b3cbd84..ec1259c777 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -9,16 +9,14 @@ IN: tools.deploy.windows "resource:factor.dll" swap copy-file-into ; : copy-freetype ( bundle-name -- ) - deploy-ui? get [ - { - "resource:freetype6.dll" - "resource:zlib1.dll" - } swap copy-files-into - ] [ drop ] if ; + { + "resource:freetype6.dll" + "resource:zlib1.dll" + } swap copy-files-into ; : create-exe-dir ( vocab bundle-name -- vm ) + dup copy-dll deploy-ui? get [ - dup copy-dll dup copy-freetype dup "" copy-fonts ] when @@ -26,14 +24,14 @@ IN: tools.deploy.windows M: winnt deploy* "resource:" [ - deploy-name over deploy-config at - [ - { + dup deploy-config [ + deploy-name get + [ [ create-exe-dir ] [ image-name ] [ drop ] - [ drop deploy-config ] - } 2cleave make-deploy-image - ] - [ nip open-in-explorer ] 2bi + 2tri namespace make-deploy-image + ] + [ nip open-in-explorer ] 2bi + ] bind ] with-directory ; From 9a3c10d21247eb457d13d9e58f89d25af051871c Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 19:22:04 -0500 Subject: [PATCH 24/83] Add documentation for math.analysis --- extra/math/analysis/analysis-docs.factor | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 extra/math/analysis/analysis-docs.factor diff --git a/extra/math/analysis/analysis-docs.factor b/extra/math/analysis/analysis-docs.factor new file mode 100644 index 0000000000..a810ffc1bd --- /dev/null +++ b/extra/math/analysis/analysis-docs.factor @@ -0,0 +1,24 @@ +USING: help.markup help.syntax math ; +IN: math.analysis + +HELP: gamma +{ $values { "x" number } { "y" number } } +{ $description "Gamma function; an extension of factorial to real and complex numbers." } ; + +HELP: gammaln +{ $values { "x" number } { "gamma[x]" number } } +{ $description "An alternative to " { $link gamma } " when gamma(x)'s range varies too widely." } ; + +HELP: nth-root +{ $values { "n" integer } { "x" number } { "y" number } } +{ $description "Calculates the nth root of a number, such that " { $snippet "y^n=x" } "." } ; + +HELP: exp-int +{ $values { "x" number } { "y" number } } +{ $description "Exponential integral function." } +{ $notes "Works only for real values of " { $snippet "x" } " and is accurate to 7 decimal places." } ; + +HELP: stirling-fact +{ $values { "n" integer } { "fact" integer } } +{ $description "James Stirling's factorial approximation." } ; + From 46692390d4c65ea5a4fab3941d3a58552cbc691c Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 21:00:36 -0500 Subject: [PATCH 25/83] Cleanup math.compare docs and tests --- extra/math/compare/compare-docs.factor | 36 ++++++++----------------- extra/math/compare/compare-tests.factor | 9 +------ 2 files changed, 12 insertions(+), 33 deletions(-) diff --git a/extra/math/compare/compare-docs.factor b/extra/math/compare/compare-docs.factor index eb199cd5fe..6c20db10fd 100644 --- a/extra/math/compare/compare-docs.factor +++ b/extra/math/compare/compare-docs.factor @@ -1,37 +1,23 @@ -! Copyright (C) 2008 John Benediktsson -! See http://factorcode.org/license.txt for BSD license - -USING: help.markup help.syntax ; - +USING: help.markup help.syntax math ; IN: math.compare HELP: absmin -{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } } -{ $description - "Returns the smaller absolute number with the original sign." -} ; +{ $values { "a" number } { "b" number } { "x" number } } +{ $description "Returns the smaller absolute number with the original sign." } ; HELP: absmax -{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } } -{ $description - "Returns the larger absolute number with the original sign." -} ; +{ $values { "a" number } { "b" number } { "x" number } } +{ $description "Returns the larger absolute number with the original sign." } ; HELP: posmax -{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } } -{ $description - "Returns the most-positive value, or zero if both are negative." -} ; +{ $values { "a" number } { "b" number } { "x" number } } +{ $description "Returns the most-positive value, or zero if both are negative." } ; HELP: negmin -{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } } -{ $description - "Returns the most-negative value, or zero if both are positive." -} ; +{ $values { "a" number } { "b" number } { "x" number } } +{ $description "Returns the most-negative value, or zero if both are positive." } ; HELP: clamp -{ $values { "a" "a number" } { "value" "a number" } { "b" "a number" } { "x" "a number" } } -{ $description - "Returns the value when between 'a' and 'b', 'a' if <= 'a', or 'b' if >= 'b'." -} ; +{ $values { "a" number } { "value" number } { "b" number } { "x" number } } +{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ; diff --git a/extra/math/compare/compare-tests.factor b/extra/math/compare/compare-tests.factor index 765f34e695..272471fe5d 100644 --- a/extra/math/compare/compare-tests.factor +++ b/extra/math/compare/compare-tests.factor @@ -1,8 +1,4 @@ -! Copyright (C) 2008 John Benediktsson -! See http://factorcode.org/license.txt for BSD license - -USING: kernel math math.functions math.compare tools.test ; - +USING: kernel math math.compare math.functions tools.test ; IN: math.compare.tests [ -1 ] [ -1 5 absmin ] unit-test @@ -23,6 +19,3 @@ IN: math.compare.tests [ 1 ] [ 0 1 2 clamp ] unit-test [ 2 ] [ 0 3 2 clamp ] unit-test - - - From 930458ebd7e316a3ed4dacda98f5124879bcf307 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 21:42:01 -0500 Subject: [PATCH 26/83] Move fft/haar transforms to their own subdirectory --- extra/math/{ => transforms}/fft/authors.txt | 0 extra/math/transforms/fft/fft-docs.factor | 7 +++++++ extra/math/{ => transforms}/fft/fft.factor | 2 +- extra/math/{ => transforms}/fft/summary.txt | 0 extra/math/{ => transforms}/haar/authors.txt | 0 extra/math/transforms/haar/haar-docs.factor | 15 +++++++++++++++ .../math/{ => transforms}/haar/haar-tests.factor | 5 +++-- extra/math/{ => transforms}/haar/haar.factor | 2 +- extra/math/{ => transforms}/haar/summary.txt | 0 extra/math/transforms/summary.txt | 1 + 10 files changed, 28 insertions(+), 4 deletions(-) rename extra/math/{ => transforms}/fft/authors.txt (100%) create mode 100644 extra/math/transforms/fft/fft-docs.factor rename extra/math/{ => transforms}/fft/fft.factor (96%) rename extra/math/{ => transforms}/fft/summary.txt (100%) rename extra/math/{ => transforms}/haar/authors.txt (100%) create mode 100644 extra/math/transforms/haar/haar-docs.factor rename extra/math/{ => transforms}/haar/haar-tests.factor (65%) rename extra/math/{ => transforms}/haar/haar.factor (96%) rename extra/math/{ => transforms}/haar/summary.txt (100%) create mode 100644 extra/math/transforms/summary.txt diff --git a/extra/math/fft/authors.txt b/extra/math/transforms/fft/authors.txt similarity index 100% rename from extra/math/fft/authors.txt rename to extra/math/transforms/fft/authors.txt diff --git a/extra/math/transforms/fft/fft-docs.factor b/extra/math/transforms/fft/fft-docs.factor new file mode 100644 index 0000000000..430058b362 --- /dev/null +++ b/extra/math/transforms/fft/fft-docs.factor @@ -0,0 +1,7 @@ +USING: help.markup help.syntax sequences ; +IN: math.transforms.fft + +HELP: fft +{ $values { "seq" sequence } { "seq" sequence } } +{ $description "Fast Fourier transform function." } ; + diff --git a/extra/math/fft/fft.factor b/extra/math/transforms/fft/fft.factor similarity index 96% rename from extra/math/fft/fft.factor rename to extra/math/transforms/fft/fft.factor index 7dfdc0bcfc..0688c00468 100644 --- a/extra/math/fft/fft.factor +++ b/extra/math/transforms/fft/fft.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: columns grouping kernel math math.constants math.functions math.vectors sequences ; -IN: math.fft +IN: math.transforms.fft ! Fast Fourier Transform diff --git a/extra/math/fft/summary.txt b/extra/math/transforms/fft/summary.txt similarity index 100% rename from extra/math/fft/summary.txt rename to extra/math/transforms/fft/summary.txt diff --git a/extra/math/haar/authors.txt b/extra/math/transforms/haar/authors.txt similarity index 100% rename from extra/math/haar/authors.txt rename to extra/math/transforms/haar/authors.txt diff --git a/extra/math/transforms/haar/haar-docs.factor b/extra/math/transforms/haar/haar-docs.factor new file mode 100644 index 0000000000..218a63a480 --- /dev/null +++ b/extra/math/transforms/haar/haar-docs.factor @@ -0,0 +1,15 @@ +USING: help.markup help.syntax sequences ; +IN: math.transforms.haar + +HELP: haar +{ $values { "seq" sequence } { "seq" sequence } } +{ $description "Haar wavelet transform function." } +{ $notes "The sequence length should be a power of two." } +{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 7 1 6 6 3 -5 4 2 } haar ." "{ 3 2 -1 -2 3 0 4 1 }" } } ; + +HELP: rev-haar +{ $values { "seq" sequence } { "seq" sequence } } +{ $description "Reverse Haar wavelet transform function." } +{ $notes "The sequence length should be a power of two." } +{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 3 2 -1 -2 3 0 4 1 } rev-haar ." "{ 7 1 6 6 3 -5 4 2 }" } } ; + diff --git a/extra/math/haar/haar-tests.factor b/extra/math/transforms/haar/haar-tests.factor similarity index 65% rename from extra/math/haar/haar-tests.factor rename to extra/math/transforms/haar/haar-tests.factor index 9c9124bf17..fd2ab90c0d 100644 --- a/extra/math/haar/haar-tests.factor +++ b/extra/math/transforms/haar/haar-tests.factor @@ -1,5 +1,6 @@ -USING: math.haar tools.test ; -IN: math.haar.tests +USING: math.transforms.haar tools.test ; +IN: math.transforms.haar.tests [ { 3 2 -1 -2 3 0 4 1 } ] [ { 7 1 6 6 3 -5 4 2 } haar ] unit-test [ { 7 1 6 6 3 -5 4 2 } ] [ { 3 2 -1 -2 3 0 4 1 } rev-haar ] unit-test + diff --git a/extra/math/haar/haar.factor b/extra/math/transforms/haar/haar.factor similarity index 96% rename from extra/math/haar/haar.factor rename to extra/math/transforms/haar/haar.factor index f745721124..c0359b8e7b 100644 --- a/extra/math/haar/haar.factor +++ b/extra/math/transforms/haar/haar.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs columns grouping kernel math math.statistics math.vectors sequences ; -IN: math.haar +IN: math.transforms.haar ! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/ diff --git a/extra/math/haar/summary.txt b/extra/math/transforms/haar/summary.txt similarity index 100% rename from extra/math/haar/summary.txt rename to extra/math/transforms/haar/summary.txt diff --git a/extra/math/transforms/summary.txt b/extra/math/transforms/summary.txt new file mode 100644 index 0000000000..d3d93df124 --- /dev/null +++ b/extra/math/transforms/summary.txt @@ -0,0 +1 @@ +Collection of mathematical transforms From e813e1df1849c18eea3111f52c6352158ea97a1a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 21:42:59 -0500 Subject: [PATCH 27/83] Add unit tests for math.derivatives --- extra/math/derivatives/derivatives-tests.factor | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 extra/math/derivatives/derivatives-tests.factor diff --git a/extra/math/derivatives/derivatives-tests.factor b/extra/math/derivatives/derivatives-tests.factor new file mode 100644 index 0000000000..cfbc1fa6ec --- /dev/null +++ b/extra/math/derivatives/derivatives-tests.factor @@ -0,0 +1,5 @@ +USING: math math.derivatives tools.test ; +IN: math.derivatives.test + +[ 8 ] [ 4 [ sq ] derivative >integer ] unit-test + From 61db7d846b34101cbd7a51f50474b0aafb3a1808 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 22:10:42 -0500 Subject: [PATCH 28/83] Switch zero? to 0 = where appropriate in PE solutions --- extra/project-euler/001/001.factor | 2 +- extra/project-euler/004/004.factor | 2 +- extra/project-euler/014/014.factor | 2 +- extra/project-euler/019/019.factor | 4 ++-- extra/project-euler/047/047.factor | 2 +- extra/project-euler/052/052.factor | 2 +- extra/project-euler/common/common.factor | 6 +++--- 7 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 344b0f1209..1e49be9a60 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -46,7 +46,7 @@ PRIVATE> : euler001b ( -- answer ) - 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ; + 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ euler001b ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor index eb5f97b2de..e1918f5fa6 100644 --- a/extra/project-euler/004/004.factor +++ b/extra/project-euler/004/004.factor @@ -21,7 +21,7 @@ IN: project-euler.004 diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index 62e2e066ff..16a7139f51 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -33,7 +33,7 @@ IN: project-euler.019 : euler019 ( -- answer ) 1901 2000 [a,b] [ 12 [1,b] [ 1 zeller-congruence ] with map - ] map concat [ zero? ] count ; + ] map concat [ 0 = ] count ; ! [ euler019 ] 100 ave-time ! 1 ms ave run time - 0.51 SD (100 trials) @@ -58,7 +58,7 @@ IN: project-euler.019 PRIVATE> : euler019a ( -- answer ) - end-date start-date first-days [ zero? ] count ; + end-date start-date first-days [ 0 = ] count ; ! [ euler019a ] 100 ave-time ! 17 ms ave run time - 2.13 SD (100 trials) diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor index 84041babb7..30c01d8f61 100644 --- a/extra/project-euler/047/047.factor +++ b/extra/project-euler/047/047.factor @@ -66,7 +66,7 @@ SYMBOL: sieve 0 >array sieve set ; : is-prime? ( index -- ? ) - sieve get nth zero? ; + sieve get nth 0 = ; : multiples ( n -- seq ) sieve get length 1- over ; diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor index 5362a6e9b0..c382d992f6 100644 --- a/extra/project-euler/052/052.factor +++ b/extra/project-euler/052/052.factor @@ -30,7 +30,7 @@ IN: project-euler.052 [ number>digits natural-sort ] map all-equal? ; : candidate? ( n -- ? ) - { [ odd? ] [ 3 mod zero? ] } 1&& ; + { [ odd? ] [ 3 mod 0 = ] } 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 d3263bbc1e..8176414153 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -42,7 +42,7 @@ IN: project-euler.common : (sum-divisors) ( n -- sum ) dup sqrt >fixnum [1,b] [ - [ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each + [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if ] { } make sum ; @@ -68,7 +68,7 @@ PRIVATE> ] if ; : number>digits ( n -- seq ) - [ dup zero? not ] [ 10 /mod ] [ ] produce reverse nip ; + [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ; : nth-triangle ( n -- n ) dup 1+ * 2 / ; @@ -112,7 +112,7 @@ PRIVATE> factor-2s dup [ 1+ ] [ perfect-square? -1 0 ? ] [ dup sqrt >fixnum [1,b] ] tri* [ - dupd mod zero? [ [ 2 + ] dip ] when + dupd mod 0 = [ [ 2 + ] dip ] when ] each drop * ; ! These transforms are for generating primitive Pythagorean triples From b04bc4d866883cc0864dae4cfdc435e1c5586e12 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 10 Nov 2008 00:58:43 -0500 Subject: [PATCH 29/83] Solution to Project Euler problem 71 --- extra/project-euler/071/071-tests.factor | 4 ++ extra/project-euler/071/071.factor | 52 ++++++++++++++++++++++++ 2 files changed, 56 insertions(+) create mode 100644 extra/project-euler/071/071-tests.factor create mode 100644 extra/project-euler/071/071.factor diff --git a/extra/project-euler/071/071-tests.factor b/extra/project-euler/071/071-tests.factor new file mode 100644 index 0000000000..ba61d7640b --- /dev/null +++ b/extra/project-euler/071/071-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.071 tools.test ; +IN: project-euler.071.tests + +[ 428570 ] [ euler071 ] unit-test diff --git a/extra/project-euler/071/071.factor b/extra/project-euler/071/071.factor new file mode 100644 index 0000000000..1fc08c3548 --- /dev/null +++ b/extra/project-euler/071/071.factor @@ -0,0 +1,52 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.ratios sequences ; +IN: project-euler.071 + +! http://projecteuler.net/index.php?section=problems&id=71 + +! DESCRIPTION +! ----------- + +! Consider the fraction, n/d, where n and d are positive integers. If nfraction ] bi@ swapd [ + ] 2bi@ / ; + +PRIVATE> + +: euler071 ( -- answer ) + 2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] [ ] produce + nip penultimate numerator ; + +! [ euler071 ] 100 ave-time +! 155 ms ave run time - 6.95 SD (100 trials) + +MAIN: euler071 From b8eebd5c2be585b506b00e57f2307ec35f3db1ce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 Nov 2008 00:16:11 -0600 Subject: [PATCH 30/83] swap over == tuck; dupd swap == over --- basis/io/unix/launcher/parser/parser.factor | 2 +- basis/peg/ebnf/ebnf.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/unix/launcher/parser/parser.factor b/basis/io/unix/launcher/parser/parser.factor index e5e83ab4e9..276ed45f27 100644 --- a/basis/io/unix/launcher/parser/parser.factor +++ b/basis/io/unix/launcher/parser/parser.factor @@ -29,5 +29,5 @@ IN: io.unix.launcher.parser PEG: tokenize-command ( command -- ast/f ) 'argument' " " token repeat1 list-of - " " token repeat0 swap over pack + " " token repeat0 tuck pack just ; diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 776450ccd9..ccae0fec93 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -487,7 +487,7 @@ M: ebnf-terminal (transform) ( ast -- parser ) M: ebnf-foreign (transform) ( ast -- parser ) dup word>> search [ "Foreign word '" swap word>> append "' not found" append throw ] unless* - swap rule>> [ main ] unless* dupd swap rule [ + swap rule>> [ main ] unless* over rule [ nip ] [ execute From 57af68f7ed49dfcb3b6217731407cd2bd6ee4433 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sun, 9 Nov 2008 22:20:12 -0800 Subject: [PATCH 31/83] add project-euler.215 --- extra/project-euler/215/215-tests.factor | 5 +++ extra/project-euler/215/215.factor | 56 ++++++++++++++++++++++++ 2 files changed, 61 insertions(+) create mode 100644 extra/project-euler/215/215-tests.factor create mode 100644 extra/project-euler/215/215.factor diff --git a/extra/project-euler/215/215-tests.factor b/extra/project-euler/215/215-tests.factor new file mode 100644 index 0000000000..ddd87cc2ff --- /dev/null +++ b/extra/project-euler/215/215-tests.factor @@ -0,0 +1,5 @@ +USING: project-euler.215 tools.test ; +IN: project-euler.215.tests + +[ 8 ] [ 9 3 solve ] unit-test +[ 806844323190414 ] [ euler215 ] unit-test diff --git a/extra/project-euler/215/215.factor b/extra/project-euler/215/215.factor new file mode 100644 index 0000000000..056de72e50 --- /dev/null +++ b/extra/project-euler/215/215.factor @@ -0,0 +1,56 @@ +USING: accessors kernel locals math ; +IN: project-euler.215 + +TUPLE: block two three ; +TUPLE: end { ways integer } ; + +C: block +C: end +: 0 ; inline +: 1 ; inline + +: failure? ( t -- ? ) ways>> 0 = ; inline + +: choice ( t p q -- t t ) [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline + +GENERIC: merge ( t t -- t ) +GENERIC# block-merge 1 ( t t -- t ) +GENERIC# end-merge 1 ( t t -- t ) +M: block merge block-merge ; +M: end merge end-merge ; +M: block block-merge [ [ two>> ] bi@ merge ] + [ [ three>> ] bi@ merge ] 2bi ; +M: end block-merge nip ; +M: block end-merge drop ; +M: end end-merge [ ways>> ] bi@ + ; + +GENERIC: h-1 ( t -- t ) +GENERIC: h0 ( t -- t ) +GENERIC: h1 ( t -- t ) +GENERIC: h2 ( t -- t ) + +M: block h-1 [ h1 ] [ h2 ] choice merge ; +M: block h0 drop ; +M: block h1 [ [ h1 ] [ h2 ] choice merge ] + [ [ h0 ] [ h1 ] choice merge ] bi ; +M: block h2 [ h1 ] [ h2 ] choice merge swap ; + +M: end h-1 drop ; +M: end h0 ; +M: end h1 drop ; +M: end h2 dup failure? [ ] unless ; + +: next-row ( t -- t ) [ h-1 ] [ h1 ] choice swap ; + +: first-row ( n -- t ) + [ ] dip + 1- [| a b c | b c a b ] times 2drop ; + +GENERIC: total ( t -- n ) +M: block total [ total ] dup choice + ; +M: end total ways>> ; + +: solve ( width height -- ways ) + [ first-row ] dip 1- [ next-row ] times total ; + +: euler215 ( -- ways ) 32 10 solve ; From 6df7342b812b53a6c15e7ce100251baaef50c63d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 10 Nov 2008 02:10:18 -0600 Subject: [PATCH 32/83] ui.gadgets.scrollers: Nicer version of 'find-scroller*' --- basis/ui/gadgets/scrollers/scrollers.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index 633e3ad4a8..8c63e15a4d 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -4,7 +4,8 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math namespaces sequences models models.range models.compose -combinators math.vectors classes.tuple math.geometry.rect ; +combinators math.vectors classes.tuple math.geometry.rect +combinators.short-circuit ; IN: ui.gadgets.scrollers TUPLE: scroller < frame viewport x y follows ; @@ -70,13 +71,10 @@ scroller H{ : relative-scroll-rect ( rect gadget scroller -- newrect ) viewport>> gadget-child relative-loc offset-rect ; -: find-scroller* ( gadget -- scroller ) - dup find-scroller dup [ - 2dup viewport>> gadget-child - swap child? [ nip ] [ 2drop f ] if - ] [ - 2drop f - ] if ; +: find-scroller* ( gadget -- scroller/f ) + dup find-scroller + { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] } + 2&& ; : scroll>rect ( rect gadget -- ) dup find-scroller* dup [ From 359f177a984e16b25e54b613b9565965453e30d7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 10 Nov 2008 02:40:14 -0600 Subject: [PATCH 33/83] Remove 'builder' vocabulary (now called 'mason') --- extra/builder/build/build.factor | 46 -------- extra/builder/builder.factor | 21 ---- extra/builder/child/child.factor | 68 ------------ extra/builder/cleanup/cleanup.factor | 26 ----- extra/builder/common/common.factor | 54 ---------- extra/builder/email/email.factor | 24 ----- extra/builder/release/archive/archive.factor | 69 ------------ extra/builder/release/branch/branch.factor | 40 ------- extra/builder/release/release.factor | 27 ----- extra/builder/release/tidy/tidy.factor | 29 ----- extra/builder/release/upload/upload.factor | 54 ---------- extra/builder/report/report.factor | 35 ------ extra/builder/test/test.factor | 35 ------ extra/builder/updates/updates.factor | 31 ------ extra/builder/util/util.factor | 106 ------------------- 15 files changed, 665 deletions(-) delete mode 100644 extra/builder/build/build.factor delete mode 100644 extra/builder/builder.factor delete mode 100644 extra/builder/child/child.factor delete mode 100644 extra/builder/cleanup/cleanup.factor delete mode 100644 extra/builder/common/common.factor delete mode 100644 extra/builder/email/email.factor delete mode 100644 extra/builder/release/archive/archive.factor delete mode 100644 extra/builder/release/branch/branch.factor delete mode 100644 extra/builder/release/release.factor delete mode 100644 extra/builder/release/tidy/tidy.factor delete mode 100644 extra/builder/release/upload/upload.factor delete mode 100644 extra/builder/report/report.factor delete mode 100644 extra/builder/test/test.factor delete mode 100644 extra/builder/updates/updates.factor delete mode 100644 extra/builder/util/util.factor diff --git a/extra/builder/build/build.factor b/extra/builder/build/build.factor deleted file mode 100644 index e9f58980ea..0000000000 --- a/extra/builder/build/build.factor +++ /dev/null @@ -1,46 +0,0 @@ - -USING: io.files io.launcher io.encodings.utf8 prettyprint - builder.util builder.common builder.child builder.release - builder.report builder.email builder.cleanup ; - -IN: builder.build - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: create-build-dir ( -- ) - datestamp >stamp - build-dir make-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: enter-build-dir ( -- ) build-dir set-current-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: clone-builds-factor ( -- ) - { "git" "clone" builds/factor } to-strings try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: record-id ( -- ) - "factor" - [ git-id "../git-id" utf8 [ . ] with-file-writer ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: build ( -- ) - reset-status - create-build-dir - enter-build-dir - clone-builds-factor - record-id - build-child - release - report - email-report - cleanup ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: build \ No newline at end of file diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor deleted file mode 100644 index 29daa8160b..0000000000 --- a/extra/builder/builder.factor +++ /dev/null @@ -1,21 +0,0 @@ - -USING: kernel debugger io.files threads calendar - builder.common - builder.updates - builder.build ; - -IN: builder - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: build-loop ( -- ) - builds-check - [ - builds/factor set-current-directory - new-code-available? [ build ] when - ] - try - 5 minutes sleep - build-loop ; - -MAIN: build-loop \ No newline at end of file diff --git a/extra/builder/child/child.factor b/extra/builder/child/child.factor deleted file mode 100644 index 0f701dfdd7..0000000000 --- a/extra/builder/child/child.factor +++ /dev/null @@ -1,68 +0,0 @@ - -USING: namespaces debugger io.files io.launcher accessors bootstrap.image - calendar builder.util builder.common ; - -IN: builder.child - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: make-vm ( -- ) - - gnu-make >>command - "../compile-log" >>stdout - +stdout+ >>stderr - try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ; - -: copy-image ( -- ) - builds-factor-image ".." copy-file-into - builds-factor-image "." copy-file-into ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: boot-cmd ( -- cmd ) - { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; - -: boot ( -- ) - - boot-cmd >>command - +closed+ >>stdin - "../boot-log" >>stdout - +stdout+ >>stderr - 60 minutes >>timeout - try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ; - -: test ( -- ) - - test-cmd >>command - +closed+ >>stdin - "../test-log" >>stdout - +stdout+ >>stderr - 240 minutes >>timeout - try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: (build-child) ( -- ) - make-clean - make-vm status-vm on - copy-image - boot status-boot on - test status-test on - status on ; - -: build-child ( -- ) - "factor" set-current-directory - [ (build-child) ] try - ".." set-current-directory ; \ No newline at end of file diff --git a/extra/builder/cleanup/cleanup.factor b/extra/builder/cleanup/cleanup.factor deleted file mode 100644 index e601506fb4..0000000000 --- a/extra/builder/cleanup/cleanup.factor +++ /dev/null @@ -1,26 +0,0 @@ - -USING: kernel namespaces io.files io.launcher bootstrap.image - builder.util builder.common ; - -IN: builder.cleanup - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: builder-debug - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; - -: delete-child-factor ( -- ) - build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ; - -: cleanup ( -- ) - builder-debug get f = - [ - "test-log" delete-file - delete-child-factor - compress-image - ] - when ; - diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor deleted file mode 100644 index 474606e451..0000000000 --- a/extra/builder/common/common.factor +++ /dev/null @@ -1,54 +0,0 @@ - -USING: kernel namespaces sequences splitting - io io.files io.launcher io.encodings.utf8 prettyprint - vars builder.util ; - -IN: builder.common - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: upload-to-factorcode - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: builds-dir - -: builds ( -- path ) - builds-dir get - home "/builds" append - or ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: stamp - -: builds/factor ( -- path ) builds "factor" append-path ; -: build-dir ( -- path ) builds stamp> append-path ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: prepare-build-machine ( -- ) - builds make-directory - builds - [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: status-vm -SYMBOL: status-boot -SYMBOL: status-test -SYMBOL: status-build -SYMBOL: status-release -SYMBOL: status - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: reset-status ( -- ) - { status-vm status-boot status-test status-build status-release status } - [ off ] - each ; diff --git a/extra/builder/email/email.factor b/extra/builder/email/email.factor deleted file mode 100644 index ecde47f8f7..0000000000 --- a/extra/builder/email/email.factor +++ /dev/null @@ -1,24 +0,0 @@ - -USING: kernel namespaces accessors smtp builder.util builder.common ; - -IN: builder.email - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: builder-from -SYMBOL: builder-recipients - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ; - -: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ; - -: email-report ( -- ) - - builder-from get >>from - builder-recipients get >>to - subject >>subject - "report" file>string >>body - send-email ; - diff --git a/extra/builder/release/archive/archive.factor b/extra/builder/release/archive/archive.factor deleted file mode 100644 index 25153436e6..0000000000 --- a/extra/builder/release/archive/archive.factor +++ /dev/null @@ -1,69 +0,0 @@ - -USING: kernel combinators system sequences io.files io.launcher prettyprint - builder.util - builder.common ; - -IN: builder.release.archive - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: base-name ( -- string ) - { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ; - -: extension ( -- extension ) - { - { [ os winnt? ] [ ".zip" ] } - { [ os macosx? ] [ ".dmg" ] } - { [ os unix? ] [ ".tar.gz" ] } - } - cond ; - -: archive-name ( -- string ) base-name extension append ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ; - -! : macosx-archive-cmd ( -- cmd ) -! { "hdiutil" "create" -! "-srcfolder" "factor" -! "-fs" "HFS+" -! "-volname" "factor" -! archive-name } ; - -: macosx-archive-cmd ( -- cmd ) - { "mkdir" "dmg-root" } try-process - { "cp" "-r" "factor" "dmg-root" } try-process - { "hdiutil" "create" - "-srcfolder" "dmg-root" - "-fs" "HFS+" - "-volname" "factor" - archive-name } to-strings try-process - { "rm" "-rf" "dmg-root" } try-process - { "true" } ; - -: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: archive-cmd ( -- cmd ) - { - { [ os windows? ] [ windows-archive-cmd ] } - { [ os macosx? ] [ macosx-archive-cmd ] } - { [ os unix? ] [ unix-archive-cmd ] } - } - cond ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: make-archive ( -- ) archive-cmd to-strings try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: releases ( -- path ) - builds "releases" append-path - dup exists? not - [ dup make-directory ] - when ; - -: save-archive ( -- ) archive-name releases move-file-into ; \ No newline at end of file diff --git a/extra/builder/release/branch/branch.factor b/extra/builder/release/branch/branch.factor deleted file mode 100644 index 6b1266bb45..0000000000 --- a/extra/builder/release/branch/branch.factor +++ /dev/null @@ -1,40 +0,0 @@ - -USING: kernel system namespaces sequences prettyprint io.files io.launcher - bootstrap.image - builder.util - builder.common ; - -IN: builder.release.branch - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: branch-name ( -- string ) "clean-" platform append ; - -: refspec ( -- string ) "master:" branch-name append ; - -: push-to-clean-branch ( -- ) - { "git" "push" "factorcode.org:/git/factor.git" refspec } - to-strings - try-process ; - -: upload-clean-image ( -- ) - { - "scp" - my-boot-image-name - { "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform } - } - to-strings - try-process ; - -: (update-clean-branch) ( -- ) - "factor" - [ - push-to-clean-branch - upload-clean-image - ] - with-directory ; - -: update-clean-branch ( -- ) - upload-to-factorcode get - [ (update-clean-branch) ] - when ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor deleted file mode 100644 index 28ce3e8b35..0000000000 --- a/extra/builder/release/release.factor +++ /dev/null @@ -1,27 +0,0 @@ - -USING: kernel debugger system namespaces sequences splitting combinators - io io.files io.launcher prettyprint bootstrap.image - combinators.cleave - builder.util - builder.common - builder.release.branch - builder.release.tidy - builder.release.archive - builder.release.upload ; - -IN: builder.release - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: (release) ( -- ) - update-clean-branch - tidy - make-archive - upload - save-archive - status-release on ; - -: clean-build? ( -- ? ) - { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ; - -: release ( -- ) [ clean-build? [ (release) ] when ] try ; \ No newline at end of file diff --git a/extra/builder/release/tidy/tidy.factor b/extra/builder/release/tidy/tidy.factor deleted file mode 100644 index f8f27e75f2..0000000000 --- a/extra/builder/release/tidy/tidy.factor +++ /dev/null @@ -1,29 +0,0 @@ - -USING: kernel system io.files io.launcher builder.util ; - -IN: builder.release.tidy - -: common-files ( -- seq ) - { - "boot.x86.32.image" - "boot.x86.64.image" - "boot.macosx-ppc.image" - "boot.linux-ppc.image" - "vm" - "temp" - "logs" - ".git" - ".gitignore" - "Makefile" - "unmaintained" - "build-support" - } ; - -: remove-common-files ( -- ) - { "rm" "-rf" common-files } to-strings try-process ; - -: remove-factor-app ( -- ) - os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ; - -: tidy ( -- ) - "factor" [ remove-factor-app remove-common-files ] with-directory ; diff --git a/extra/builder/release/upload/upload.factor b/extra/builder/release/upload/upload.factor deleted file mode 100644 index 19d3936fd9..0000000000 --- a/extra/builder/release/upload/upload.factor +++ /dev/null @@ -1,54 +0,0 @@ - -USING: kernel namespaces make sequences arrays io io.files - builder.util - builder.common - builder.release.archive ; - -IN: builder.release.upload - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: upload-host - -SYMBOL: upload-username - -SYMBOL: upload-directory - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: remote-location ( -- dest ) - upload-directory get platform append ; - -: remote-archive-name ( -- dest ) - remote-location "/" archive-name 3append ; - -: temp-archive-name ( -- dest ) - remote-archive-name ".incomplete" append ; - -: upload-command ( -- args ) - "scp" - archive-name - [ upload-username get % "@" % upload-host get % ":" % temp-archive-name % ] "" make - 3array ; - -: rename-command ( -- args ) - [ - "ssh" , - upload-host get , - "-l" , - upload-username get , - "mv" , - temp-archive-name , - remote-archive-name , - ] { } make ; - -: upload-temp-file ( -- ) - upload-command [ "Error uploading binary to factorcode" print ] run-or-bail ; - -: rename-temp-file ( -- ) - rename-command [ "Error renaming binary on factorcode" print ] run-or-bail ; - -: upload ( -- ) - upload-to-factorcode get - [ upload-temp-file rename-temp-file ] - when ; diff --git a/extra/builder/report/report.factor b/extra/builder/report/report.factor deleted file mode 100644 index 2ac8482a76..0000000000 --- a/extra/builder/report/report.factor +++ /dev/null @@ -1,35 +0,0 @@ - -USING: kernel namespaces debugger system io io.files io.sockets - io.encodings.utf8 prettyprint benchmark - builder.util builder.common ; - -IN: builder.report - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: (report) ( -- ) - - "Build machine: " write host-name print - "CPU: " write cpu . - "OS: " write os . - "Build directory: " write build-dir print - "git id: " write "git-id" eval-file print nl - - status-vm get f = [ "compile-log" cat "vm compile error" throw ] when - status-boot get f = [ "boot-log" 100 cat-n "Boot error" throw ] when - status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when - - "Boot time: " write "boot-time" eval-file milli-seconds>time print - "Load time: " write "load-time" eval-file milli-seconds>time print - "Test time: " write "test-time" eval-file milli-seconds>time print nl - - "Did not pass load-everything: " print "load-everything-vocabs" cat - - "Did not pass test-all: " print "test-all-vocabs" cat - "test-failures" cat - - "help-lint results:" print "help-lint" cat - - "Benchmarks: " print "benchmarks" eval-file benchmarks. ; - -: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ; \ No newline at end of file diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor deleted file mode 100644 index 2a0769f278..0000000000 --- a/extra/builder/test/test.factor +++ /dev/null @@ -1,35 +0,0 @@ - -USING: kernel namespaces assocs - io.files io.encodings.utf8 prettyprint - help.lint - benchmark - tools.time - bootstrap.stage2 - tools.test tools.vocabs - builder.util ; - -IN: builder.test - -: do-load ( -- ) - try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ; - -: do-tests ( -- ) - run-all-tests - [ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ] - [ "../test-failures" utf8 [ test-failures. ] with-file-writer ] - bi ; - -: do-help-lint ( -- ) - "" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ; - -: do-benchmarks ( -- ) - run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ; - -: do-all ( -- ) - bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer - [ do-load ] benchmark "../load-time" utf8 [ . ] with-file-writer - [ do-tests ] benchmark "../test-time" utf8 [ . ] with-file-writer - do-help-lint - do-benchmarks ; - -MAIN: do-all \ No newline at end of file diff --git a/extra/builder/updates/updates.factor b/extra/builder/updates/updates.factor deleted file mode 100644 index a8184550e0..0000000000 --- a/extra/builder/updates/updates.factor +++ /dev/null @@ -1,31 +0,0 @@ - -USING: kernel io.launcher bootstrap.image bootstrap.image.download - builder.util builder.common ; - -IN: builder.updates - -: git-pull-cmd ( -- cmd ) - { - "git" - "pull" - "--no-summary" - "git://factorcode.org/git/factor.git" - "master" - } ; - -: updates-available? ( -- ? ) - git-id - git-pull-cmd try-process - git-id - = not ; - -: new-image-available? ( -- ? ) - my-boot-image-name need-new-image? - [ download-my-image t ] - [ f ] - if ; - -: new-code-available? ( -- ? ) - updates-available? - new-image-available? - or ; \ No newline at end of file diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor deleted file mode 100644 index 32d1e45066..0000000000 --- a/extra/builder/util/util.factor +++ /dev/null @@ -1,106 +0,0 @@ - -USING: kernel words namespaces classes parser continuations - io io.files io.launcher io.sockets - math math.parser - system - combinators sequences splitting quotations arrays strings tools.time - sequences.deep accessors assocs.lib - io.encodings.utf8 - combinators.cleave calendar calendar.format eval ; - -IN: builder.util - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: minutes>ms ( min -- ms ) 60 * 1000 * ; - -: file>string ( file -- string ) utf8 file-contents ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -DEFER: to-strings - -: to-string ( obj -- str ) - dup class - { - { \ string [ ] } - { \ quotation [ call ] } - { \ word [ execute ] } - { \ fixnum [ number>string ] } - { \ array [ to-strings concat ] } - } - case ; - -: to-strings ( seq -- str ) - dup [ string? ] all? - [ ] - [ [ to-string ] map flatten ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: host-name* ( -- name ) host-name "." split first ; - -: datestamp ( -- string ) - now - { year>> month>> day>> hour>> minute>> } - [ pad-00 ] map "-" join ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: milli-seconds>time ( n -- string ) - 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; - -: eval-file ( file -- obj ) utf8 file-contents eval ; - -: cat ( file -- ) utf8 file-contents print ; - -: run-or-bail ( desc quot -- ) - [ [ try-process ] curry ] - [ [ throw ] compose ] - bi* - recover ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: bootstrap.image bootstrap.image.download io.streams.null ; - -: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: longer? ( seq seq -- ? ) [ length ] bi@ > ; - -: maybe-tail* ( seq n -- seq ) - 2dup longer? - [ tail* ] - [ drop ] - if ; - -: cat-n ( file n -- ) - [ utf8 file-lines ] [ ] bi* - maybe-tail* - [ print ] each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USE: prettyprint - -: to-file ( object file -- ) utf8 [ . ] with-file-writer ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: cpu- ( -- cpu ) cpu unparse "." split "-" join ; - -: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: gnu-make ( -- string ) - os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-id ( -- id ) - { "git" "show" } utf8 [ readln ] with-input-stream - " " split second ; From 33a082c361e890874097ac9dfdf6e4d459c23bad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 Nov 2008 02:43:16 -0600 Subject: [PATCH 34/83] Fix reference to obsolete G: word --- core/generic/standard/standard-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index 1d98dec87c..15913b46be 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -16,7 +16,7 @@ HELP: standard-combination { $examples "A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:" { $code - "G: build-string 1 standard-combination ;" + "GENERIC# build-string 1 ( elt str -- )" "M: string build-string swap push-all ;" "M: integer build-string push ;" } From 5b7d40d9b48f7abd19949db6391466f37d59b0c2 Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 10 Nov 2008 02:58:05 -0600 Subject: [PATCH 35/83] We need to end the basic block after the ##prologue in the dispatch branch so that the GC check can go after the prologue --- basis/compiler/cfg/builder/builder.factor | 1 + basis/compiler/tests/templates.factor | 11 +++++++++++ 2 files changed, 12 insertions(+) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 93daa601fe..17a5942af2 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -171,6 +171,7 @@ M: #if emit-node [ V{ } clone node-stack set ##prologue + begin-basic-block emit-nodes basic-block get [ ##epilogue diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor index de87ad8c00..0a109a15eb 100644 --- a/basis/compiler/tests/templates.factor +++ b/basis/compiler/tests/templates.factor @@ -219,3 +219,14 @@ TUPLE: my-tuple ; : bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f ; [ { f f f } ] [ t bad-value-bug ] unit-test + +! PowerPC regression +TUPLE: id obj ; + +: (gc-check-bug) ( a b -- c ) + { [ id boa ] [ id boa ] } dispatch ; + +: gc-check-bug ( -- ) + 10000000 [ "hi" 0 (gc-check-bug) drop ] times ; + +[ ] [ gc-check-bug ] unit-test From ffe4bd6787125f6d94785510a480fc1d57e43067 Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 10 Nov 2008 03:18:58 -0600 Subject: [PATCH 36/83] Various updates --- basis/cpu/ppc/ppc.factor | 100 +++++++++++++++++++++------------------ 1 file changed, 53 insertions(+), 47 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 2be46d15ee..49caae4bb8 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -4,7 +4,8 @@ USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words alien alien.c-types cpu.architecture cpu.ppc.assembler compiler.cfg.registers compiler.cfg.instructions -compiler.constants compiler.codegen compiler.codegen.fixup ; +compiler.constants compiler.codegen compiler.codegen.fixup +compiler.cfg.intrinsics compiler.cfg.stack-frame ; IN: cpu.ppc ! PowerPC register assignments: @@ -15,15 +16,19 @@ IN: cpu.ppc ! f0-f29: float vregs ! f30, f31: float scratch +enable-float-intrinsics + +<< \ ##integer>float t frame-required? set-word-prop +\ ##float>integer t frame-required? set-word-prop >> + M: ppc machine-registers { { int-regs T{ range f 2 26 1 } } - { double-float-regs T{ range f 0 28 1 } } + { double-float-regs T{ range f 0 29 1 } } } ; : scratch-reg 28 ; inline -: fp-scratch-reg-1 29 ; inline -: fp-scratch-reg-2 30 ; inline +: fp-scratch-reg 30 ; inline M: ppc two-operand? f ; @@ -54,8 +59,16 @@ M: ppc %inc-d ( n -- ) ds-reg (%inc) ; M: ppc %inc-r ( n -- ) rs-reg (%inc) ; HOOK: reserved-area-size os ( -- n ) -HOOK: lr-save os ( -- n ) +! The start of the stack frame contains the size of this frame +! as well as the currently executing XT +: factor-area-size ( -- n ) 2 cells ; foldable +: next-save ( n -- i ) cell - ; +: xt-save ( n -- i ) 2 cells - ; + +! Next, we have the spill area as well as the FFI parameter area. +! They overlap, since basic blocks with FFI calls will never +! spill. : param@ ( n -- x ) reserved-area-size + ; inline : param-save-size ( -- n ) 8 cells ; foldable @@ -63,19 +76,34 @@ HOOK: lr-save os ( -- n ) : local@ ( n -- x ) reserved-area-size param-save-size + + ; inline -: factor-area-size ( -- n ) 2 cells ; foldable +: spill-integer-base ( -- n ) + stack-frame get spill-counts>> double-float-regs swap at + double-float-regs reg-size * ; -: next-save ( n -- i ) cell - ; +: spill-integer@ ( n -- offset ) + cells spill-integer-base + param@ ; -: xt-save ( n -- i ) 2 cells - ; +: spill-float@ ( n -- offset ) + double-float-regs reg-size * param@ ; + +! Some FP intrinsics need a temporary scratch area in the stack +! frame, 8 bytes in size +: scratch@ ( n -- offset ) + stack-frame get total-size>> + factor-area-size - + param-save-size - + + ; + +! Finally we have the linkage area +HOOK: lr-save os ( -- n ) M: ppc stack-frame-size ( stack-frame -- i ) [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] [ params>> ] [ return>> ] tri + + - reserved-area-size + param-save-size + + reserved-area-size + factor-area-size + 4 cells align ; @@ -198,19 +226,19 @@ M: ppc %div-float FDIV ; M:: ppc %integer>float ( dst src -- ) HEX: 4330 scratch-reg LIS - scratch-reg 1 0 param@ STW + scratch-reg 1 0 scratch@ STW scratch-reg src MR scratch-reg dup HEX: 8000 XORIS - scratch-reg 1 cell param@ STW - fp-scratch-reg-2 1 0 param@ LFD + scratch-reg 1 4 scratch@ STW + dst 1 0 scratch@ LFD scratch-reg 4503601774854144.0 %load-indirect - fp-scratch-reg-2 scratch-reg float-offset LFD - fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ; + fp-scratch-reg scratch-reg float-offset LFD + dst dst fp-scratch-reg FSUB ; M:: ppc %float>integer ( dst src -- ) - fp-scratch-reg-1 src FCTIWZ - fp-scratch-reg-2 1 0 param@ STFD - dst 1 4 param@ LWZ ; + fp-scratch-reg src FCTIWZ + fp-scratch-reg 1 0 scratch@ STFD + dst 1 4 scratch@ LWZ ; M: ppc %copy ( dst src -- ) MR ; @@ -218,6 +246,10 @@ M: ppc %copy-float ( dst src -- ) FMR ; M: ppc %unbox-float ( dst src -- ) float-offset LFD ; +M:: ppc %box-float ( dst src temp -- ) + dst 16 float temp %allot + src dst float-offset STFD ; + M:: ppc %unbox-any-c-ptr ( dst src temp -- ) [ { "is-byte-array" "end" "start" } [ define-label ] each @@ -349,11 +381,6 @@ M: ppc %gc "end" resolve-label ; M: ppc %prologue ( n -- ) - #! We use a volatile register (r11) here for scratch. Because - #! callback bodies have a prologue too, we cannot assume - #! that c_to_factor saved all non-volatile registers, so - #! we have to respect the C calling convention. Also, we - #! cannot touch any param-regs either. 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this 0 MFLR 1 1 pick neg ADDI @@ -410,32 +437,11 @@ M: ppc %compare-branch (%compare) %branch ; M: ppc %compare-imm-branch (%compare-imm) %branch ; M: ppc %compare-float-branch (%compare-float) %branch ; -: spill-integer-base ( stack-frame -- n ) - [ params>> ] [ return>> ] bi + ; +M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ; +M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ; -: stack@ 1 swap ; inline - -: spill-integer@ ( n -- reg offset ) - cells - stack-frame get spill-integer-base - + stack@ ; - -: spill-float-base ( stack-frame -- n ) - [ spill-counts>> int-regs swap at int-regs reg-size * ] - [ params>> ] - [ return>> ] - tri + + ; - -: spill-float@ ( n -- reg offset ) - double-float-regs reg-size * - stack-frame get spill-float-base - + stack@ ; - -M: ppc %spill-integer ( src n -- ) spill-integer@ STW ; -M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ; - -M: ppc %spill-float ( src n -- ) spill-float@ STFD ; -M: ppc %reload-float ( dst n -- ) spill-float@ LFD ; +M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ; +M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ; M: ppc %loop-entry ; From 17be33fb013b2fd94f7d4efe7dac5ca7f39bc835 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 10 Nov 2008 03:35:21 -0600 Subject: [PATCH 37/83] ui.gadgets.labelled: Simplify '' --- basis/ui/gadgets/labelled/labelled.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index 8cf13c8367..37b1d251e8 100644 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -39,7 +39,7 @@ M: labelled-gadget focusable-child* content>> ; : ( title quot -- gadget ) - swap dup [ @left grid-add ] [ drop ] if + swap [ @left grid-add ] when* swap @center grid-add ; TUPLE: closable-gadget < frame content ; From eeb53283d4c1ec4ed86b9b2d2ca53315a45d4ccf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 Nov 2008 05:07:25 -0600 Subject: [PATCH 38/83] Update code for builder removal --- basis/tools/test/test-docs.factor | 2 +- {extra => unmaintained}/size-of/size-of.factor | 0 {extra => unmaintained}/update/backup/backup.factor | 0 {extra => unmaintained}/update/latest/latest.factor | 0 {extra => unmaintained}/update/update.factor | 0 5 files changed, 1 insertion(+), 1 deletion(-) rename {extra => unmaintained}/size-of/size-of.factor (100%) rename {extra => unmaintained}/update/backup/backup.factor (100%) rename {extra => unmaintained}/update/latest/latest.factor (100%) rename {extra => unmaintained}/update/update.factor (100%) diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 4b2521d19c..02c0ad126d 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -17,7 +17,7 @@ ARTICLE: "tools.test.run" "Running unit tests" { $subsection test-all } ; ARTICLE: "tools.test.failure" "Handling test failures" -"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Sometimes, you want to develop a tool which inspects the test failures and takes some kind of action instead; one example is " { $vocab-link "builder" } "." +"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "." $nl "The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:" { $list diff --git a/extra/size-of/size-of.factor b/unmaintained/size-of/size-of.factor similarity index 100% rename from extra/size-of/size-of.factor rename to unmaintained/size-of/size-of.factor diff --git a/extra/update/backup/backup.factor b/unmaintained/update/backup/backup.factor similarity index 100% rename from extra/update/backup/backup.factor rename to unmaintained/update/backup/backup.factor diff --git a/extra/update/latest/latest.factor b/unmaintained/update/latest/latest.factor similarity index 100% rename from extra/update/latest/latest.factor rename to unmaintained/update/latest/latest.factor diff --git a/extra/update/update.factor b/unmaintained/update/update.factor similarity index 100% rename from extra/update/update.factor rename to unmaintained/update/update.factor From d8a3439bc24a4aab986c826376eeb50f6ee4b2da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 Nov 2008 05:08:30 -0600 Subject: [PATCH 39/83] Fix indentation --- basis/ui/gadgets/scrollers/scrollers.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index 8c63e15a4d..d1429c4006 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -73,7 +73,7 @@ scroller H{ : find-scroller* ( gadget -- scroller/f ) dup find-scroller - { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] } + { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] } 2&& ; : scroll>rect ( rect gadget -- ) From 9be9538230014e62f71fe671f043a25c0aaf5586 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 10 Nov 2008 12:38:01 -0500 Subject: [PATCH 40/83] Update Project Euler using line --- extra/project-euler/project-euler.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index d85e7e206d..1e808e6321 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: definitions io io.files kernel math math.parser project-euler.ave-time - sequences vocabs vocabs.loader prettyprint +USING: definitions io io.files kernel math math.parser + prettyprint project-euler.ave-time sequences vocabs vocabs.loader project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 @@ -15,11 +15,12 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time 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.059 project-euler.067 project-euler.075 project-euler.076 - project-euler.079 project-euler.092 project-euler.097 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.059 project-euler.067 project-euler.071 project-euler.075 + project-euler.076 project-euler.079 project-euler.092 project-euler.097 + 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 ; IN: project-euler Date: Mon, 10 Nov 2008 12:51:43 -0500 Subject: [PATCH 41/83] Move ratio mediant word to project-euler.common --- extra/project-euler/071/071.factor | 5 +---- extra/project-euler/common/common.factor | 8 ++++++-- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/project-euler/071/071.factor b/extra/project-euler/071/071.factor index 1fc08c3548..feecd997fa 100644 --- a/extra/project-euler/071/071.factor +++ b/extra/project-euler/071/071.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.ratios sequences ; +USING: kernel math project-euler.common sequences ; IN: project-euler.071 ! http://projecteuler.net/index.php?section=problems&id=71 @@ -37,9 +37,6 @@ IN: project-euler.071 : penultimate ( seq -- elt ) dup length 2 - swap nth ; -: mediant ( a/c b/d -- [a+b]/[c+d] ) - [ >fraction ] bi@ swapd [ + ] 2bi@ / ; - PRIVATE> : euler071 ( -- answer ) diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 8176414153..35d9c65b53 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,8 +1,8 @@ ! Copyright (c) 2007-2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel make math math.functions math.matrices math.miller-rabin - math.order math.parser math.primes.factors math.ranges sequences - sequences.lib sorting strings unicode.case ; + math.order math.parser math.primes.factors math.ranges math.ratios + sequences sequences.lib sorting strings unicode.case ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -14,6 +14,7 @@ IN: project-euler.common ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56 ! log10 - #25, #134 ! max-path - #18, #67 +! mediant - #71, #73 ! nth-triangle - #12, #42 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92 ! palindrome? - #4, #36, #55 @@ -60,6 +61,9 @@ PRIVATE> : log10 ( m -- n ) log 10 log / ; +: mediant ( a/c b/d -- (a+b)/(c+d) ) + 2>fraction [ + ] 2bi@ / ; + : max-path ( triangle -- n ) dup length 1 > [ 2 cut* first2 max-children [ + ] 2map suffix max-path From 6189bfd1f08954d6748001f0c7e2c73f859caafb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 10 Nov 2008 17:01:14 -0800 Subject: [PATCH 42/83] bring cairo bindings back from the dead --- basis/opengl/opengl.factor | 10 +++---- extra/opengl/gadgets/gadgets.factor | 2 +- unmaintained/cairo/cairo.factor | 2 +- unmaintained/cairo/ffi/ffi.factor | 2 +- unmaintained/cairo/gadgets/gadgets.factor | 21 +++++++------- unmaintained/cairo/samples/samples.factor | 34 ++++++++++++++++------- 6 files changed, 43 insertions(+), 28 deletions(-) diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index bae05f4244..5d9baf644d 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -16,17 +16,17 @@ IN: opengl : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) [ first2 [ >fixnum ] bi@ ] bi@ ; -: gl-color ( color -- ) first4 glColor4d ; inline +: color>raw ( object -- r g b a ) + >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; + +: gl-color ( color -- ) color>raw glColor4d ; inline : gl-clear-color ( color -- ) - first4 glClearColor ; + color>raw glClearColor ; : gl-clear ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ; -: color>raw ( object -- r g b a ) - >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; - : set-color ( object -- ) color>raw glColor4d ; : set-clear-color ( object -- ) color>raw glClearColor ; diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor index 9e670c04ab..cfedf32079 100644 --- a/extra/opengl/gadgets/gadgets.factor +++ b/extra/opengl/gadgets/gadgets.factor @@ -6,7 +6,7 @@ fry assocs destructors sequences ui.render colors ; IN: opengl.gadgets -TUPLE: texture-gadget ; +TUPLE: texture-gadget < gadget ; GENERIC: render* ( gadget -- texture dims ) GENERIC: cache-key* ( gadget -- key ) diff --git a/unmaintained/cairo/cairo.factor b/unmaintained/cairo/cairo.factor index 46d3e42c2b..aa7d1159a6 100755 --- a/unmaintained/cairo/cairo.factor +++ b/unmaintained/cairo/cairo.factor @@ -33,4 +33,4 @@ SYMBOL: cairo >r r> [ (with-surface) ] curry with-disposal ; inline : with-cairo-from-surface ( cairo_surface quot -- ) - '[ cairo_create , with-cairo ] with-surface ; inline + '[ cairo_create _ with-cairo ] with-surface ; inline diff --git a/unmaintained/cairo/ffi/ffi.factor b/unmaintained/cairo/ffi/ffi.factor index 451806c0a7..db18320fee 100644 --- a/unmaintained/cairo/ffi/ffi.factor +++ b/unmaintained/cairo/ffi/ffi.factor @@ -10,7 +10,7 @@ alien.c-types accessors sequences arrays ui.gadgets ; IN: cairo.ffi << "cairo" { { [ os winnt? ] [ "libcairo-2.dll" ] } - { [ os macosx? ] [ "libcairo.dylib" ] } + { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } { [ os unix? ] [ "libcairo.so.2" ] } } cond "cdecl" add-library >> diff --git a/unmaintained/cairo/gadgets/gadgets.factor b/unmaintained/cairo/gadgets/gadgets.factor index c9fef618f8..d160740c44 100644 --- a/unmaintained/cairo/gadgets/gadgets.factor +++ b/unmaintained/cairo/gadgets/gadgets.factor @@ -3,7 +3,7 @@ USING: sequences math opengl.gadgets kernel byte-arrays cairo.ffi cairo io.backend ui.gadgets accessors opengl.gl -arrays ; +arrays fry classes ; IN: cairo.gadgets @@ -15,21 +15,22 @@ IN: cairo.gadgets [ cairo_image_surface_create_for_data ] 3bi r> with-cairo-from-surface ; inline -TUPLE: cairo-gadget < texture-gadget dim quot ; +TUPLE: cairo-gadget < texture-gadget ; -: ( dim quot -- gadget ) - cairo-gadget construct-gadget - swap >>quot +: ( dim -- gadget ) + cairo-gadget new-gadget swap >>dim ; -M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ; +M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ; : render-cairo ( dim quot -- bytes format ) >r 2^-bounds r> copy-cairo GL_BGRA ; inline -! M: cairo-gadget render* -! [ dim>> dup ] [ quot>> ] bi -! render-cairo render-bytes* ; +GENERIC: render-cairo* ( gadget -- ) + +M: cairo-gadget render* + [ dim>> dup ] [ '[ _ render-cairo* ] ] bi + render-cairo render-bytes* ; ! maybe also texture>png ! : cairo>png ( gadget path -- ) @@ -44,7 +45,7 @@ M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ; TUPLE: png-gadget < texture-gadget path ; : ( path -- gadget ) - png-gadget construct-gadget + png-gadget new-gadget swap >>path ; M: png-gadget render* diff --git a/unmaintained/cairo/samples/samples.factor b/unmaintained/cairo/samples/samples.factor index 0e83381349..0f21142f2a 100644 --- a/unmaintained/cairo/samples/samples.factor +++ b/unmaintained/cairo/samples/samples.factor @@ -4,11 +4,13 @@ ! these samples are a subset of the samples on ! http://cairographics.org/samples/ USING: cairo cairo.ffi locals math.constants math -io.backend kernel alien.c-types libc namespaces ; +io.backend kernel alien.c-types libc namespaces +cairo.gadgets ui.gadgets accessors ; IN: cairo.samples -:: arc ( -- ) +TUPLE: arc-gadget < cairo-gadget ; +M:: arc-gadget render-cairo* ( gadget -- ) [let | xc [ 128.0 ] yc [ 128.0 ] radius [ 100.0 ] @@ -32,7 +34,9 @@ IN: cairo.samples cr cairo_stroke ] ; -: clip ( -- ) +TUPLE: clip-gadget < cairo-gadget ; +M: clip-gadget render-cairo* ( gadget -- ) + drop cr 128 128 76.8 0 2 pi * cairo_arc cr cairo_clip cr cairo_new_path @@ -47,7 +51,8 @@ IN: cairo.samples cr 10 cairo_set_line_width cr cairo_stroke ; -:: clip-image ( -- ) +TUPLE: clip-image-gadget < cairo-gadget ; +M:: clip-image-gadget render-cairo* ( gadget -- ) [let* | png [ "resource:misc/icons/Factor_128x128.png" normalize-path cairo_image_surface_create_from_png ] w [ png cairo_image_surface_get_width ] @@ -62,7 +67,8 @@ IN: cairo.samples png cairo_surface_destroy ] ; -:: dash ( -- ) +TUPLE: dash-gadget < cairo-gadget ; +M:: dash-gadget render-cairo* ( gadget -- ) [let | dashes [ { 50 10 10 10 } >c-double-array ] ndash [ 4 ] | cr dashes ndash -50 cairo_set_dash @@ -74,7 +80,8 @@ IN: cairo.samples cr cairo_stroke ] ; -:: gradient ( -- ) +TUPLE: gradient-gadget < cairo-gadget ; +M:: gradient-gadget render-cairo* ( gadget -- ) [let | pat [ 0 0 0 256 cairo_pattern_create_linear ] radial [ 115.2 102.4 25.6 102.4 102.4 128.0 cairo_pattern_create_radial ] | @@ -93,7 +100,9 @@ IN: cairo.samples radial cairo_pattern_destroy ] ; -: text ( -- ) +TUPLE: text-gadget < cairo-gadget ; +M: text-gadget render-cairo* ( gadget -- ) + drop cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face cr 50 cairo_set_font_size @@ -115,7 +124,9 @@ IN: cairo.samples cr 70 165 5.12 0 2 pi * cairo_arc cr cairo_fill ; -: utf8 ( -- ) +TUPLE: utf8-gadget < cairo-gadget ; +M: utf8-gadget render-cairo* ( gadget -- ) + drop cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL cairo_select_font_face cr 50 cairo_set_font_size @@ -141,7 +152,10 @@ IN: cairo.samples USING: quotations cairo.gadgets ui.gadgets.panes sequences ; : samples ( -- ) - { arc clip clip-image dash gradient text utf8 } - [ { 256 256 } swap 1quotation gadget. ] each ; + { + arc-gadget clip-gadget clip-image-gadget dash-gadget + gradient-gadget text-gadget utf8-gadget + } + [ new-gadget { 256 256 } >>dim gadget. ] each ; MAIN: samples From 88e03204b9dc8ae5bc9497d2d9be5dec1c98154c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 10 Nov 2008 17:05:31 -0800 Subject: [PATCH 43/83] bring cairo-demo back from the dead --- unmaintained/cairo-demo/cairo-demo.factor | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/unmaintained/cairo-demo/cairo-demo.factor b/unmaintained/cairo-demo/cairo-demo.factor index 29fb99a301..4f057ee57c 100644 --- a/unmaintained/cairo-demo/cairo-demo.factor +++ b/unmaintained/cairo-demo/cairo-demo.factor @@ -7,7 +7,7 @@ USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render - ui.gadgets opengl.gl ; + ui.gadgets opengl.gl accessors ; IN: cairo-demo @@ -20,17 +20,16 @@ IN: cairo-demo cairo_image_surface_create_for_data ; -TUPLE: cairo-gadget image-array cairo-t ; +TUPLE: cairo-gadget < gadget image-array cairo-t ; M: cairo-gadget draw-gadget* ( gadget -- ) 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r> - cairo-gadget-image-array glDrawPixels ; + image-array>> glDrawPixels ; : create-surface ( gadget -- cairo_surface_t ) - make-image-array - [ swap set-cairo-gadget-image-array ] keep + make-image-array [ swap (>>image-array) ] keep convert-array-to-surface ; : init-cairo ( gadget -- cairo_t ) @@ -39,7 +38,7 @@ M: cairo-gadget draw-gadget* ( gadget -- ) M: cairo-gadget pref-dim* drop { 384 256 0 } ; : draw-hello-world ( gadget -- ) - cairo-gadget-cairo-t + cairo-t>> dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face dup 90.0 cairo_set_font_size dup 10.0 135.0 cairo_move_to @@ -58,13 +57,13 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ; cairo_fill ; M: cairo-gadget graft* ( gadget -- ) - dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ; + dup dup init-cairo swap (>>cairo-t) draw-hello-world ; M: cairo-gadget ungraft* ( gadget -- ) - cairo-gadget-cairo-t cairo_destroy ; + cairo-t>> cairo_destroy ; : ( -- gadget ) - cairo-gadget construct-gadget ; + cairo-gadget new-gadget ; : run ( -- ) [ From c9b5934894bd49b02e3477eaa9b1f612a529f659 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 10 Nov 2008 17:07:04 -0800 Subject: [PATCH 44/83] change name of gadget in cairo-demo to avoid confusion with cairo.gadgets --- unmaintained/cairo-demo/cairo-demo.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/unmaintained/cairo-demo/cairo-demo.factor b/unmaintained/cairo-demo/cairo-demo.factor index 4f057ee57c..ea92e798a7 100644 --- a/unmaintained/cairo-demo/cairo-demo.factor +++ b/unmaintained/cairo-demo/cairo-demo.factor @@ -20,9 +20,9 @@ IN: cairo-demo cairo_image_surface_create_for_data ; -TUPLE: cairo-gadget < gadget image-array cairo-t ; +TUPLE: cairo-demo-gadget < gadget image-array cairo-t ; -M: cairo-gadget draw-gadget* ( gadget -- ) +M: cairo-demo-gadget draw-gadget* ( gadget -- ) 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r> @@ -35,7 +35,7 @@ M: cairo-gadget draw-gadget* ( gadget -- ) : init-cairo ( gadget -- cairo_t ) create-surface cairo_create ; -M: cairo-gadget pref-dim* drop { 384 256 0 } ; +M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ; : draw-hello-world ( gadget -- ) cairo-t>> @@ -56,18 +56,18 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ; dup 70.0 165.0 5.12 0 pi 2 * cairo_arc cairo_fill ; -M: cairo-gadget graft* ( gadget -- ) +M: cairo-demo-gadget graft* ( gadget -- ) dup dup init-cairo swap (>>cairo-t) draw-hello-world ; -M: cairo-gadget ungraft* ( gadget -- ) +M: cairo-demo-gadget ungraft* ( gadget -- ) cairo-t>> cairo_destroy ; -: ( -- gadget ) - cairo-gadget new-gadget ; +: ( -- gadget ) + cairo-demo-gadget new-gadget ; : run ( -- ) [ - "Hello World from Factor!" open-window + "Hello World from Factor!" open-window ] with-ui ; MAIN: run From ab366cd1ca31b61eda94ca6f985237c88a24c6fe Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 10 Nov 2008 17:07:59 -0800 Subject: [PATCH 45/83] Move cairo vocabs back into extra/ --- {unmaintained => extra}/cairo-demo/authors.txt | 0 {unmaintained => extra}/cairo-demo/cairo-demo.factor | 0 {unmaintained => extra}/cairo/authors.txt | 0 {unmaintained => extra}/cairo/cairo.factor | 0 {unmaintained => extra}/cairo/ffi/ffi.factor | 0 {unmaintained => extra}/cairo/gadgets/gadgets.factor | 0 {unmaintained => extra}/cairo/samples/samples.factor | 0 {unmaintained => extra}/cairo/summary.txt | 0 {unmaintained => extra}/cairo/tags.txt | 0 9 files changed, 0 insertions(+), 0 deletions(-) rename {unmaintained => extra}/cairo-demo/authors.txt (100%) rename {unmaintained => extra}/cairo-demo/cairo-demo.factor (100%) rename {unmaintained => extra}/cairo/authors.txt (100%) rename {unmaintained => extra}/cairo/cairo.factor (100%) rename {unmaintained => extra}/cairo/ffi/ffi.factor (100%) rename {unmaintained => extra}/cairo/gadgets/gadgets.factor (100%) rename {unmaintained => extra}/cairo/samples/samples.factor (100%) rename {unmaintained => extra}/cairo/summary.txt (100%) rename {unmaintained => extra}/cairo/tags.txt (100%) diff --git a/unmaintained/cairo-demo/authors.txt b/extra/cairo-demo/authors.txt similarity index 100% rename from unmaintained/cairo-demo/authors.txt rename to extra/cairo-demo/authors.txt diff --git a/unmaintained/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor similarity index 100% rename from unmaintained/cairo-demo/cairo-demo.factor rename to extra/cairo-demo/cairo-demo.factor diff --git a/unmaintained/cairo/authors.txt b/extra/cairo/authors.txt similarity index 100% rename from unmaintained/cairo/authors.txt rename to extra/cairo/authors.txt diff --git a/unmaintained/cairo/cairo.factor b/extra/cairo/cairo.factor similarity index 100% rename from unmaintained/cairo/cairo.factor rename to extra/cairo/cairo.factor diff --git a/unmaintained/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor similarity index 100% rename from unmaintained/cairo/ffi/ffi.factor rename to extra/cairo/ffi/ffi.factor diff --git a/unmaintained/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor similarity index 100% rename from unmaintained/cairo/gadgets/gadgets.factor rename to extra/cairo/gadgets/gadgets.factor diff --git a/unmaintained/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor similarity index 100% rename from unmaintained/cairo/samples/samples.factor rename to extra/cairo/samples/samples.factor diff --git a/unmaintained/cairo/summary.txt b/extra/cairo/summary.txt similarity index 100% rename from unmaintained/cairo/summary.txt rename to extra/cairo/summary.txt diff --git a/unmaintained/cairo/tags.txt b/extra/cairo/tags.txt similarity index 100% rename from unmaintained/cairo/tags.txt rename to extra/cairo/tags.txt From 262e9632e624edd68a9a444d8effe7aef1658ccf Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 10 Nov 2008 19:17:41 -0600 Subject: [PATCH 46/83] Remove 'unmaintained/update' (moving back to 'extra') --- unmaintained/update/backup/backup.factor | 28 ----------- unmaintained/update/latest/latest.factor | 53 -------------------- unmaintained/update/update.factor | 64 ------------------------ 3 files changed, 145 deletions(-) delete mode 100644 unmaintained/update/backup/backup.factor delete mode 100644 unmaintained/update/latest/latest.factor delete mode 100644 unmaintained/update/update.factor diff --git a/unmaintained/update/backup/backup.factor b/unmaintained/update/backup/backup.factor deleted file mode 100644 index 0dcf853b98..0000000000 --- a/unmaintained/update/backup/backup.factor +++ /dev/null @@ -1,28 +0,0 @@ - -USING: namespaces debugger io.files bootstrap.image builder.util ; - -IN: update.backup - -: backup-boot-image ( -- ) - my-boot-image-name - { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string - move-file ; - -: backup-image ( -- ) - "factor.image" - { "factor" "-" [ "datestamp" get ] ".image" } to-string - move-file ; - -: backup-vm ( -- ) - "factor" - { "factor" "-" [ "datestamp" get ] } to-string - move-file ; - -: backup ( -- ) - datestamp "datestamp" set - [ - backup-boot-image - backup-image - backup-vm - ] - try ; diff --git a/unmaintained/update/latest/latest.factor b/unmaintained/update/latest/latest.factor deleted file mode 100644 index df057422f9..0000000000 --- a/unmaintained/update/latest/latest.factor +++ /dev/null @@ -1,53 +0,0 @@ - -USING: kernel namespaces system io.files bootstrap.image http.client - builder.util update update.backup ; - -IN: update.latest - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-pull-master ( -- ) - image parent-directory - [ - { "git" "pull" "git://factorcode.org/git/factor.git" "master" } - run-command - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: remote-latest-image ( -- url ) - { "http://factorcode.org/images/latest/" my-boot-image-name } to-string ; - -: download-latest-image ( -- ) remote-latest-image download ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: rebuild-latest ( -- ) - image parent-directory - [ - backup - download-latest-image - make-clean - make - boot - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: update-latest ( -- ) - image parent-directory - [ - git-id - git-pull-master - git-id - = not - [ rebuild-latest ] - when - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: update-latest \ No newline at end of file diff --git a/unmaintained/update/update.factor b/unmaintained/update/update.factor deleted file mode 100644 index 1d25a9792e..0000000000 --- a/unmaintained/update/update.factor +++ /dev/null @@ -1,64 +0,0 @@ - -USING: kernel system sequences io.files io.launcher bootstrap.image - http.client - builder.util builder.release.branch ; - -IN: update - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: run-command ( cmd -- ) to-strings try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-pull-clean ( -- ) - image parent-directory - [ - { "git" "pull" "git://factorcode.org/git/factor.git" branch-name } - run-command - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: remote-clean-image ( -- url ) - { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name } - to-string ; - -: download-clean-image ( -- ) remote-clean-image download ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: make-clean ( -- ) { gnu-make "clean" } run-command ; -: make ( -- ) { gnu-make } run-command ; -: boot ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: rebuild ( -- ) - image parent-directory - [ - download-clean-image - make-clean - make - boot - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: update ( -- ) - image parent-directory - [ - git-id - git-pull-clean - git-id - = not - [ rebuild ] - when - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: update \ No newline at end of file From 7104cd4fe8e63f89495f5f25e3f748690c87f903 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 10 Nov 2008 19:20:08 -0600 Subject: [PATCH 47/83] Fix 'extra/update' --- extra/update/backup/backup.factor | 28 +++++++++++++ extra/update/latest/latest.factor | 53 +++++++++++++++++++++++++ extra/update/update.factor | 66 +++++++++++++++++++++++++++++++ extra/update/util/util.factor | 62 +++++++++++++++++++++++++++++ 4 files changed, 209 insertions(+) create mode 100644 extra/update/backup/backup.factor create mode 100644 extra/update/latest/latest.factor create mode 100644 extra/update/update.factor create mode 100644 extra/update/util/util.factor diff --git a/extra/update/backup/backup.factor b/extra/update/backup/backup.factor new file mode 100644 index 0000000000..0c7b442ffa --- /dev/null +++ b/extra/update/backup/backup.factor @@ -0,0 +1,28 @@ + +USING: namespaces debugger io.files bootstrap.image update.util ; + +IN: update.backup + +: backup-boot-image ( -- ) + my-boot-image-name + { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string + move-file ; + +: backup-image ( -- ) + "factor.image" + { "factor" "-" [ "datestamp" get ] ".image" } to-string + move-file ; + +: backup-vm ( -- ) + "factor" + { "factor" "-" [ "datestamp" get ] } to-string + move-file ; + +: backup ( -- ) + datestamp "datestamp" set + [ + backup-boot-image + backup-image + backup-vm + ] + try ; diff --git a/extra/update/latest/latest.factor b/extra/update/latest/latest.factor new file mode 100644 index 0000000000..7cc2fac853 --- /dev/null +++ b/extra/update/latest/latest.factor @@ -0,0 +1,53 @@ + +USING: kernel namespaces system io.files bootstrap.image http.client + update update.backup update.util ; + +IN: update.latest + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: git-pull-master ( -- ) + image parent-directory + [ + { "git" "pull" "git://factorcode.org/git/factor.git" "master" } + run-command + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remote-latest-image ( -- url ) + { "http://factorcode.org/images/latest/" my-boot-image-name } to-string ; + +: download-latest-image ( -- ) remote-latest-image download ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rebuild-latest ( -- ) + image parent-directory + [ + backup + download-latest-image + make-clean + make + boot + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: update-latest ( -- ) + image parent-directory + [ + git-id + git-pull-master + git-id + = not + [ rebuild-latest ] + when + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: update-latest \ No newline at end of file diff --git a/extra/update/update.factor b/extra/update/update.factor new file mode 100644 index 0000000000..c6a5671345 --- /dev/null +++ b/extra/update/update.factor @@ -0,0 +1,66 @@ + +USING: kernel system sequences io.files io.launcher bootstrap.image + http.client + update.util ; + + ! builder.util builder.release.branch ; + +IN: update + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run-command ( cmd -- ) to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: git-pull-clean ( -- ) + image parent-directory + [ + { "git" "pull" "git://factorcode.org/git/factor.git" branch-name } + run-command + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remote-clean-image ( -- url ) + { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name } + to-string ; + +: download-clean-image ( -- ) remote-clean-image download ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-clean ( -- ) { gnu-make "clean" } run-command ; +: make ( -- ) { gnu-make } run-command ; +: boot ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rebuild ( -- ) + image parent-directory + [ + download-clean-image + make-clean + make + boot + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: update ( -- ) + image parent-directory + [ + git-id + git-pull-clean + git-id + = not + [ rebuild ] + when + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: update \ No newline at end of file diff --git a/extra/update/util/util.factor b/extra/update/util/util.factor new file mode 100644 index 0000000000..b638b61528 --- /dev/null +++ b/extra/update/util/util.factor @@ -0,0 +1,62 @@ + +USING: kernel classes strings quotations words math math.parser arrays + combinators.cleave + accessors + system prettyprint splitting + sequences combinators sequences.deep + io + io.launcher + io.encodings.utf8 + calendar + calendar.format ; + +IN: update.util + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: to-strings + +: to-string ( obj -- str ) + dup class + { + { \ string [ ] } + { \ quotation [ call ] } + { \ word [ execute ] } + { \ fixnum [ number>string ] } + { \ array [ to-strings concat ] } + } + case ; + +: to-strings ( seq -- str ) + dup [ string? ] all? + [ ] + [ [ to-string ] map flatten ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cpu- ( -- cpu ) cpu unparse "." split "-" join ; + +: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: branch-name ( -- string ) "clean-" platform append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gnu-make ( -- string ) + os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: git-id ( -- id ) + { "git" "show" } utf8 [ readln ] with-input-stream + " " split second ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: datestamp ( -- string ) + now + { year>> month>> day>> hour>> minute>> } + [ pad-00 ] map "-" join ; From 78d9452b7ef05851baee92363cbc34a71cc7bd43 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 10 Nov 2008 20:05:50 -0600 Subject: [PATCH 48/83] basis/bootstrap/stage2: Show core bootstrap time in report --- basis/bootstrap/stage2.factor | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 3b6c04329c..67c6c9487d 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -8,6 +8,8 @@ definitions assocs compiler.errors compiler.units math.parser generic sets debugger command-line ; IN: bootstrap.stage2 +SYMBOL: core-bootstrap-time + SYMBOL: bootstrap-time : default-image-name ( -- string ) @@ -30,7 +32,14 @@ SYMBOL: bootstrap-time : count-words ( pred -- ) all-words swap count number>string write ; -: print-report ( time -- ) +: print-report ( -- ) + core-bootstrap-time get + 1000 /i + 60 /mod swap + "Core bootstrap completed in " write number>string write + " minutes and " write number>string write " seconds." print + + bootstrap-time get 1000 /i 60 /mod swap "Bootstrap completed in " write number>string write @@ -46,7 +55,7 @@ SYMBOL: bootstrap-time [ ! We time bootstrap - millis >r + millis default-image-name "output-image" set-global @@ -71,6 +80,8 @@ SYMBOL: bootstrap-time [ load-components + millis over - core-bootstrap-time set-global + run-bootstrap-init ] with-compiler-errors :errors @@ -92,7 +103,7 @@ SYMBOL: bootstrap-time ] [ print-error 1 exit ] recover ] set-boot-quot - millis r> - dup bootstrap-time set-global + millis swap - bootstrap-time set-global print-report "output-image" get save-image-and-exit From 2489ac5205997307e704168d9d8b373358820ef0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 10 Nov 2008 21:27:48 -0600 Subject: [PATCH 49/83] bootstrap.stage2: Factor out 'print-time' --- basis/bootstrap/stage2.factor | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 67c6c9487d..d25394e978 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -32,18 +32,15 @@ SYMBOL: bootstrap-time : count-words ( pred -- ) all-words swap count number>string write ; -: print-report ( -- ) - core-bootstrap-time get +: print-time ( time -- ) 1000 /i 60 /mod swap - "Core bootstrap completed in " write number>string write - " minutes and " write number>string write " seconds." print + number>string write + " minutes and " write number>string write " seconds." print ; - bootstrap-time get - 1000 /i - 60 /mod swap - "Bootstrap completed in " write number>string write - " minutes and " write number>string write " seconds." print +: print-report ( -- ) + "Core bootstrap completed in " write core-bootstrap-time get print-time + "Bootstrap completed in " write bootstrap-time get print-time [ compiled>> ] count-words " compiled words" print [ symbol? ] count-words " symbol words" print From 8ace93a75f9c62cc78b9569a6656724333589944 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Mon, 10 Nov 2008 19:34:36 -0800 Subject: [PATCH 50/83] add project-euler.203 --- extra/project-euler/203/203-tests.factor | 5 +++++ extra/project-euler/203/203.factor | 9 +++++++++ 2 files changed, 14 insertions(+) create mode 100644 extra/project-euler/203/203-tests.factor create mode 100644 extra/project-euler/203/203.factor diff --git a/extra/project-euler/203/203-tests.factor b/extra/project-euler/203/203-tests.factor new file mode 100644 index 0000000000..6c49c2f958 --- /dev/null +++ b/extra/project-euler/203/203-tests.factor @@ -0,0 +1,5 @@ +USING: project-euler.203 tools.test ; +IN: project-euler.203.tests + +[ 105 ] [ 8 solve ] unit-test +[ 34029210557338 ] [ 51 solve ] unit-test diff --git a/extra/project-euler/203/203.factor b/extra/project-euler/203/203.factor new file mode 100644 index 0000000000..9a2916649e --- /dev/null +++ b/extra/project-euler/203/203.factor @@ -0,0 +1,9 @@ +USING: fry kernel math math.primes.factors sequences sets ; +IN: project-euler.203 + +: iterate ( n initial quot -- results ) swapd '[ @ dup ] replicate nip ; inline +: (generate) ( seq -- seq ) [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ; +: generate ( n -- seq ) 1- { 1 } [ (generate) ] iterate concat prune ; +: squarefree ( n -- ? ) factors duplicates empty? ; +: solve ( n -- n ) generate [ squarefree ] filter sum ; +: euler203 ( -- n ) 51 solve ; From 3b204ff971dbbc05f1f47442b62a7ecc6f863d22 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 10 Nov 2008 22:56:37 -0500 Subject: [PATCH 51/83] Solution to Project Euler problem 73 --- extra/project-euler/073/073-tests.factor | 4 ++ extra/project-euler/073/073.factor | 52 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 12 +++--- 3 files changed, 62 insertions(+), 6 deletions(-) create mode 100644 extra/project-euler/073/073-tests.factor create mode 100644 extra/project-euler/073/073.factor diff --git a/extra/project-euler/073/073-tests.factor b/extra/project-euler/073/073-tests.factor new file mode 100644 index 0000000000..6389150c39 --- /dev/null +++ b/extra/project-euler/073/073-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.073 tools.test ; +IN: project-euler.073.tests + +[ 5066251 ] [ euler073 ] unit-test diff --git a/extra/project-euler/073/073.factor b/extra/project-euler/073/073.factor new file mode 100644 index 0000000000..68dcd01e0d --- /dev/null +++ b/extra/project-euler/073/073.factor @@ -0,0 +1,52 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel locals make math project-euler.common sequences ; +IN: project-euler.073 + +! http://projecteuler.net/index.php?section=problems&id=73 + +! DESCRIPTION +! ----------- + +! Consider the fraction, n/d, where n and d are positive integers. If n + +: euler073 ( -- answer ) + [ 10000 1/3 1/2 (euler073) ] { } make length ; + +! [ euler073 ] 10 ave-time +! 20506 ms ave run time - 937.07 SD (10 trials) + +MAIN: euler073 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 1e808e6321..036167865f 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -15,12 +15,12 @@ USING: definitions io io.files kernel math math.parser 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.059 project-euler.067 project-euler.071 project-euler.075 - project-euler.076 project-euler.079 project-euler.092 project-euler.097 - 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.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.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 ; IN: project-euler Date: Mon, 10 Nov 2008 23:26:38 -0500 Subject: [PATCH 52/83] Cleanup formatting of Project Euler problem 215 --- extra/project-euler/215/215-tests.factor | 2 +- extra/project-euler/215/215.factor | 46 +++++++++++++++++++++--- extra/project-euler/project-euler.factor | 2 +- 3 files changed, 43 insertions(+), 7 deletions(-) diff --git a/extra/project-euler/215/215-tests.factor b/extra/project-euler/215/215-tests.factor index ddd87cc2ff..9d265b70d2 100644 --- a/extra/project-euler/215/215-tests.factor +++ b/extra/project-euler/215/215-tests.factor @@ -1,4 +1,4 @@ -USING: project-euler.215 tools.test ; +USING: project-euler.215 project-euler.215.private tools.test ; IN: project-euler.215.tests [ 8 ] [ 9 3 solve ] unit-test diff --git a/extra/project-euler/215/215.factor b/extra/project-euler/215/215.factor index 056de72e50..fc09b37515 100644 --- a/extra/project-euler/215/215.factor +++ b/extra/project-euler/215/215.factor @@ -1,6 +1,33 @@ +! Copyright (c) 2008 Eric Mertens. +! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel locals math ; IN: project-euler.215 +! http://projecteuler.net/index.php?section=problems&id=215 + +! DESCRIPTION +! ----------- + +! Consider the problem of building a wall out of 2x1 and 3x1 bricks +! (horizontalvertical dimensions) such that, for extra strength, the gaps +! between horizontally-adjacent bricks never line up in consecutive layers, +! i.e. never form a "running crack". + +! For example, the following 93 wall is not acceptable due to the running crack +! shown in red: + +! See problem site for image... + +! There are eight ways of forming a crack-free 9x3 wall, written W(9,3) = 8. + +! Calculate W(32,10). + + +! SOLUTION +! -------- + + end : failure? ( t -- ? ) ways>> 0 = ; inline -: choice ( t p q -- t t ) [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline +: choice ( t p q -- t t ) + [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline GENERIC: merge ( t t -- t ) GENERIC# block-merge 1 ( t t -- t ) @@ -43,14 +71,22 @@ M: end h2 dup failure? [ ] unless ; : next-row ( t -- t ) [ h-1 ] [ h1 ] choice swap ; : first-row ( n -- t ) - [ ] dip - 1- [| a b c | b c a b ] times 2drop ; + [ ] dip + 1- [| a b c | b c a b ] times 2drop ; GENERIC: total ( t -- n ) M: block total [ total ] dup choice + ; M: end total ways>> ; : solve ( width height -- ways ) - [ first-row ] dip 1- [ next-row ] times total ; + [ first-row ] dip 1- [ next-row ] times total ; -: euler215 ( -- ways ) 32 10 solve ; +PRIVATE> + +: euler215 ( -- answer ) + 32 10 solve ; + +! [ euler215 ] 100 ave-time +! 208 ms ave run time - 9.06 SD (100 trials) + +MAIN: euler215 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 036167865f..9549505bf6 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -20,7 +20,7 @@ USING: definitions io io.files kernel math math.parser project-euler.097 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.186 project-euler.190 project-euler.215 ; IN: project-euler Date: Tue, 11 Nov 2008 00:28:37 -0600 Subject: [PATCH 53/83] Rewrite OpenGL rendering code - Don't use glPolygonMode to draw outline rectangles - Use vertex arrays instead of glBegin/glVertex/glEnd - Remove dead code from opengl vocabulary - draw-interior and draw-boundary are now called with origin get [ ... ] with-translation --- basis/opengl/opengl-docs.factor | 33 ---- basis/opengl/opengl.factor | 146 ++++++++---------- basis/ui/gadgets/buttons/buttons.factor | 97 ++++++++---- basis/ui/gadgets/editors/editors.factor | 6 +- basis/ui/gadgets/grid-lines/grid-lines.factor | 17 +- basis/ui/gadgets/labelled/labelled.factor | 4 +- basis/ui/gadgets/labels/labels.factor | 2 +- basis/ui/gadgets/lists/lists.factor | 8 +- basis/ui/gadgets/panes/panes.factor | 8 +- basis/ui/gadgets/theme/theme.factor | 30 ++-- basis/ui/gadgets/worlds/worlds.factor | 4 +- basis/ui/render/render.factor | 122 ++++++++++----- 12 files changed, 256 insertions(+), 221 deletions(-) diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor index 87981789a7..6752c5126c 100644 --- a/basis/opengl/opengl-docs.factor +++ b/basis/opengl/opengl-docs.factor @@ -9,14 +9,6 @@ HELP: gl-color HELP: gl-error { $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ; -HELP: do-state - { - $values - { "mode" { "One of the " { $link "opengl-geometric-primitives" } } } - { "quot" quotation } - } -{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ; - HELP: do-enabled { $values { "what" integer } { "quot" quotation } } { $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ; @@ -25,10 +17,6 @@ HELP: do-matrix { $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } } { $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ; -HELP: gl-vertex -{ $values { "point" "a pair of integers" } } -{ $description "Wrapper for " { $link glVertex2d } " taking a point object." } ; - HELP: gl-line { $values { "a" "a pair of integers" } { "b" "a pair of integers" } } { $description "Draws a line between two points." } ; @@ -41,22 +29,6 @@ HELP: gl-rect { $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } } { $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ; -HELP: rect-vertices -{ $values { "lower-left" "A pair of numbers indicating the lower-left coordinates of the rectangle." } { "upper-right" "The upper-right coordinates of the rectangle." } } -{ $description "Emits" { $link glVertex2d } " calls outlining the axis-aligned rectangle from " { $snippet "lower-left" } " to " { $snippet "upper-right" } " on the z=0 plane in counterclockwise order." } ; - -HELP: gl-fill-poly -{ $values { "points" "a sequence of pairs of integers" } } -{ $description "Draws a filled polygon." } ; - -HELP: gl-poly -{ $values { "points" "a sequence of pairs of integers" } } -{ $description "Draws the outline of a polygon." } ; - -HELP: gl-gradient -{ $values { "direction" "an orientation specifier" } { "colors" "a sequence of color specifiers" } { "dim" "a pair of integers" } } -{ $description "Draws a rectangle with top-left corner " { $snippet "{ 0 0 }" } " and dimensions " { $snippet "dim" } ", filled with a smoothly shaded transition between the colors in " { $snippet "colors" } "." } ; - HELP: gen-texture { $values { "id" integer } } { $description "Wrapper for " { $link glGenTextures } " to handle the common case of generating a single texture ID." } ; @@ -131,12 +103,10 @@ $nl { $subsection "opengl-low-level" } "Wrappers:" { $subsection gl-color } -{ $subsection gl-vertex } { $subsection gl-translate } { $subsection gen-texture } { $subsection bind-texture-unit } "Combinators:" -{ $subsection do-state } { $subsection do-enabled } { $subsection do-attribs } { $subsection do-matrix } @@ -146,9 +116,6 @@ $nl { $subsection gl-line } { $subsection gl-fill-rect } { $subsection gl-rect } -{ $subsection gl-fill-poly } -{ $subsection gl-poly } -{ $subsection gl-gradient } ; ABOUT: "gl-utilities" diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 5d9baf644d..7cf141ca6a 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -2,44 +2,31 @@ ! Portions copyright (C) 2007 Eduardo Cavazos. ! Portions copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. - USING: alien alien.c-types continuations kernel libc math macros - namespaces math.vectors math.constants math.functions - math.parser opengl.gl opengl.glu combinators arrays sequences - splitting words byte-arrays assocs colors accessors ; - +namespaces math.vectors math.constants math.functions +math.parser opengl.gl opengl.glu combinators arrays sequences +splitting words byte-arrays assocs colors accessors +generalizations locals memoize ; IN: opengl -: coordinates ( point1 point2 -- x1 y2 x2 y2 ) - [ first2 ] bi@ ; - -: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) - [ first2 [ >fixnum ] bi@ ] bi@ ; - : color>raw ( object -- r g b a ) - >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; + >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline : gl-color ( color -- ) color>raw glColor4d ; inline -: gl-clear-color ( color -- ) - color>raw glClearColor ; +: gl-clear-color ( color -- ) color>raw glClearColor ; : gl-clear ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ; -: set-color ( object -- ) color>raw glColor4d ; -: set-clear-color ( object -- ) color>raw glClearColor ; - : gl-error ( -- ) glGetError dup zero? [ "GL error: " over gluErrorString append throw ] unless drop ; -: do-state ( mode quot -- ) - swap glBegin call glEnd ; inline - : do-enabled ( what quot -- ) over glEnable dip glDisable ; inline + : do-enabled-client-state ( what quot -- ) over glEnableClientState dip glDisableClientState ; inline @@ -48,6 +35,7 @@ IN: opengl : (all-enabled) ( seq quot -- ) over [ glEnable ] each dip [ glDisable ] each ; inline + : (all-enabled-client-state) ( seq quot -- ) [ dup [ glEnableClientState ] each ] dip dip @@ -55,6 +43,7 @@ IN: opengl MACRO: all-enabled ( seq quot -- ) >r words>values r> [ (all-enabled) ] 2curry ; + MACRO: all-enabled-client-state ( seq quot -- ) >r words>values r> [ (all-enabled-client-state) ] 2curry ; @@ -62,37 +51,46 @@ MACRO: all-enabled-client-state ( seq quot -- ) swap [ glMatrixMode glPushMatrix call ] keep glMatrixMode glPopMatrix ; inline -: gl-vertex ( point -- ) - dup length { - { 2 [ first2 glVertex2d ] } - { 3 [ first3 glVertex3d ] } - { 4 [ first4 glVertex4d ] } - } case ; - -: gl-normal ( normal -- ) first3 glNormal3d ; - : gl-material ( face pname params -- ) >c-float-array glMaterialfv ; +: gl-vertex-pointer ( seq -- ) + [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline + +: gl-color-pointer ( seq -- ) + [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline + +: gl-texture-coord-pointer ( seq -- ) + [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline + +: line-vertices ( a b -- ) + append >c-float-array gl-vertex-pointer ; + : gl-line ( a b -- ) - GL_LINES [ gl-vertex gl-vertex ] do-state ; + line-vertices GL_LINES 0 2 glDrawArrays ; -: gl-fill-rect ( loc ext -- ) - coordinates glRectd ; +: (rectangle-vertices) ( dim -- vertices ) + { + [ drop 0 0 ] + [ first 0 ] + [ first2 ] + [ second 0 swap ] + } cleave 8 narray >c-float-array ; -: gl-rect ( loc ext -- ) - GL_FRONT_AND_BACK GL_LINE glPolygonMode - >r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect - GL_FRONT_AND_BACK GL_FILL glPolygonMode ; +: rectangle-vertices ( dim -- ) + (rectangle-vertices) gl-vertex-pointer ; -: (gl-poly) ( points state -- ) - [ [ gl-vertex ] each ] do-state ; +: (gl-rect) ( -- ) + GL_LINE_LOOP 0 4 glDrawArrays ; -: gl-fill-poly ( points -- ) - dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ; +: gl-rect ( dim -- ) + rectangle-vertices (gl-rect) ; -: gl-poly ( points -- ) - GL_LINE_LOOP (gl-poly) ; +: (gl-fill-rect) ( -- ) + GL_QUADS 0 4 glDrawArrays ; + +: gl-fill-rect ( dim -- ) + rectangle-vertices (gl-fill-rect) ; : circle-steps ( steps -- angles ) dup length v/n 2 pi * v*n ; @@ -109,35 +107,24 @@ MACRO: all-enabled-client-state ( seq quot -- ) : circle-points ( loc dim steps -- points ) circle-steps unit-circle adjust-points scale-points ; -: gl-circle ( loc dim steps -- ) - circle-points gl-poly ; - -: gl-fill-circle ( loc dim steps -- ) - circle-points gl-fill-poly ; - -: prepare-gradient ( direction dim -- v1 v2 ) - tuck v* [ v- ] keep ; - -: gl-gradient ( direction colors dim -- ) - GL_QUAD_STRIP [ - swap >r prepare-gradient r> - [ length dup 1- v/n ] keep [ - >r >r 2dup r> r> set-color v*n - dup gl-vertex v+ gl-vertex - ] 2each 2drop - ] do-state ; +: circle-vertices ( loc dim steps -- vertices ) + circle-points concat >c-float-array ; : (gen-gl-object) ( quot -- id ) >r 1 0 r> keep *uint ; inline + : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; + : gen-gl-buffer ( -- id ) [ glGenBuffers ] (gen-gl-object) ; : (delete-gl-object) ( id quot -- ) >r 1 swap r> call ; inline + : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; + : delete-gl-buffer ( id -- ) [ glDeleteBuffers ] (delete-gl-object) ; @@ -205,35 +192,21 @@ TUPLE: sprite loc dim dim2 dlist texture ; : gl-translate ( point -- ) first2 0.0 glTranslated ; -c-float-array ; -: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline - -: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline - -: bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline - -: bottom-right 1 1 glTexCoord2i gl-vertex ; inline - -PRIVATE> - -: four-sides ( dim -- ) - dup top-left dup top-right dup bottom-right bottom-left ; +: rect-texture-coords ( -- ) + (rect-texture-coords) gl-texture-coord-pointer ; : draw-sprite ( sprite -- ) - dup loc>> gl-translate - GL_TEXTURE_2D over texture>> glBindTexture - init-texture - GL_QUADS [ dim2>> four-sides ] do-state - GL_TEXTURE_2D 0 glBindTexture ; - -: rect-vertices ( lower-left upper-right -- ) - GL_QUADS [ - over first2 glVertex2d - dup first pick second glVertex2d - dup first2 glVertex2d - swap first swap second glVertex2d - ] do-state ; + GL_TEXTURE_COORD_ARRAY [ + dup loc>> gl-translate + GL_TEXTURE_2D over texture>> glBindTexture + init-texture rect-texture-coords + dim2>> rectangle-vertices + (gl-fill-rect) + GL_TEXTURE_2D 0 glBindTexture + ] do-enabled-client-state ; : make-sprite-dlist ( sprite -- id ) GL_MODELVIEW [ @@ -256,6 +229,9 @@ PRIVATE> : with-translation ( loc quot -- ) GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline +: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) + [ first2 [ >fixnum ] bi@ ] bi@ ; + : gl-set-clip ( loc dim -- ) fix-coordinates glScissor ; diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 4ad9e14874..9f3e3a8520 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math models namespaces sequences - strings quotations assocs combinators classes colors - classes.tuple opengl math.vectors - ui.commands ui.gadgets ui.gadgets.borders - ui.gadgets.labels ui.gadgets.theme - ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures - ui.render math.geometry.rect ; +strings quotations assocs combinators classes colors +classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets +ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme +ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures +ui.render math.geometry.rect locals alien.c-types ; IN: ui.gadgets.buttons @@ -62,10 +61,10 @@ C: button-paint } cond ; M: button-paint draw-interior - button-paint draw-interior ; + button-paint dup [ draw-interior ] [ 2drop ] if ; M: button-paint draw-boundary - button-paint draw-boundary ; + button-paint dup [ draw-boundary ] [ 2drop ] if ; : align-left ( button -- button ) { 0 1/2 } >>align ; inline @@ -103,17 +102,34 @@ repeat-button H{ #! the mouse is held down. repeat-button new-button bevel-button-theme ; -TUPLE: checkmark-paint color ; +TUPLE: checkmark-paint < caching-pen color last-vertices ; -C: checkmark-paint +: ( color -- paint ) + checkmark-paint new swap >>color ; + +c-float-array ; + +PRIVATE> + +M: checkmark-paint recompute-pen + swap dim>> checkmark-vertices >>last-vertices drop ; M: checkmark-paint draw-interior - color>> set-color - origin get [ - rect-dim - { 0 0 } over gl-line - dup { 0 1 } v* swap { 1 0 } v* gl-line - ] with-translation ; + [ compute-pen ] + [ color>> gl-color ] + [ last-vertices>> gl-vertex-pointer ] tri + GL_LINES 0 4 glDrawArrays ; : checkmark-theme ( gadget -- gadget ) f @@ -148,30 +164,47 @@ TUPLE: checkbox < button ; M: checkbox model-changed swap value>> >>selected? relayout-1 ; -TUPLE: radio-paint color ; +TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ; -C: radio-paint +: ( color -- paint ) radio-paint new swap >>color ; + + + +M: radio-paint recompute-pen + swap dim>> + [ { 4 4 } swap { 8 8 } v- 12 circle-vertices >>interior-vertices ] + [ { 1 1 } swap { 2 2 } v- 12 circle-vertices >>boundary-vertices ] bi + drop ; + +> gl-color ] bi ; + +PRIVATE> M: radio-paint draw-interior - color>> set-color - origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ; + [ (radio-paint) ] [ interior-vertices>> gl-vertex-pointer ] bi + GL_POLYGON 0 circle-steps glDrawArrays ; M: radio-paint draw-boundary - color>> set-color - origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ; + [ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi + GL_LINE_LOOP 0 circle-steps glDrawArrays ; -: radio-knob-theme ( gadget -- gadget ) - f - f - black - black - >>interior - black >>boundary ; +:: radio-knob-theme ( gadget -- gadget ) + [let | radio-paint [ black ] | + gadget + f f radio-paint radio-paint >>interior + radio-paint >>boundary + { 16 16 } >>dim + ] ; : ( -- gadget ) - - radio-knob-theme - { 16 16 } >>dim ; + radio-knob-theme ; TUPLE: radio-control < button value ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index a1026ef35a..4a5545f23c 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -127,7 +127,7 @@ M: editor ungraft* : draw-caret ( -- ) editor get focused?>> [ editor get - dup caret-color>> set-color + dup caret-color>> gl-color dup caret-loc origin get v+ swap caret-dim over v+ [ { 0.5 -0.5 } v+ ] bi@ gl-line @@ -171,7 +171,7 @@ M: editor ungraft* : draw-lines ( -- ) \ first-visible-line get [ - editor get dup color>> set-color + editor get dup color>> gl-color dup visible-lines [ draw-line 1 translate-lines ] with each ] with-editor-translation ; @@ -190,7 +190,7 @@ M: editor ungraft* (draw-selection) ; : draw-selection ( -- ) - editor get selection-color>> set-color + editor get selection-color>> gl-color editor get selection-start/end over first [ 2dup [ diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor index f4266adba1..0356e7fd4d 100644 --- a/basis/ui/gadgets/grid-lines/grid-lines.factor +++ b/basis/ui/gadgets/grid-lines/grid-lines.factor @@ -23,13 +23,10 @@ SYMBOL: grid-dim ] with each ; M: grid-lines draw-boundary - origin get [ - -0.5 -0.5 0.0 glTranslated - color>> set-color [ - dup grid set - dup rect-dim half-gap v- grid-dim set - compute-grid - { 0 1 } draw-grid-lines - { 1 0 } draw-grid-lines - ] with-scope - ] with-translation ; + color>> gl-color [ + dup grid set + dup rect-dim half-gap v- grid-dim set + compute-grid + { 0 1 } draw-grid-lines + { 1 0 } draw-grid-lines + ] with-scope ; diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index 37b1d251e8..79a485b711 100644 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -30,10 +30,10 @@ M: labelled-gadget focusable-child* content>> ; : title-theme ( gadget -- gadget ) { 1 0 } >>orientation - T{ gradient f { + { T{ rgba f 0.65 0.65 1.0 1.0 } T{ rgba f 0.65 0.45 1.0 1.0 } - } } >>interior ; + } >>interior ; : ( text -- label )