From 8ec695332a69dd193754394e2ddd774add9962c6 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 6 Nov 2008 23:21:19 -0500 Subject: [PATCH 001/147] 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 002/147] 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 003/147] 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 004/147] 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 005/147] 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 23ec6ef1228d6778248f6b217514b83c873c9235 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 8 Nov 2008 15:30:28 -0500 Subject: [PATCH 006/147] 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 007/147] 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 008/147] 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 009/147] 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 f20ab6f4e8d26a7daff973d55a03b221835e5e16 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 17:16:30 -0500 Subject: [PATCH 010/147] 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 011/147] 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 9a3c10d21247eb457d13d9e58f89d25af051871c Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 9 Nov 2008 19:22:04 -0500 Subject: [PATCH 012/147] 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 013/147] 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 014/147] 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 015/147] 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 016/147] 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 017/147] 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 9be9538230014e62f71fe671f043a25c0aaf5586 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 10 Nov 2008 12:38:01 -0500 Subject: [PATCH 018/147] 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 019/147] 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 020/147] 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 021/147] 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 022/147] 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 023/147] 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 78d9452b7ef05851baee92363cbc34a71cc7bd43 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 10 Nov 2008 20:05:50 -0600 Subject: [PATCH 024/147] 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 025/147] 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 026/147] 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 027/147] 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 028/147] 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 029/147] 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 )