steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2010-02-09 19:42:54 -08:00
parent a8e771c28f a112e52fe7
commit 09a4080772
41 changed files with 356 additions and 232 deletions

19
basis/combinators/short-circuit/short-circuit-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel math tools.test combinators.short-circuit ;
USING: kernel math tools.test combinators.short-circuit accessors ;
IN: combinators.short-circuit.tests
[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
@ -22,4 +22,19 @@ IN: combinators.short-circuit.tests
: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
[ 30 ] [ 10 20 compiled-|| ] unit-test
[ 2 ] [ 1 1 compiled-|| ] unit-test
[ 2 ] [ 1 1 compiled-|| ] unit-test
! && and || should be row-polymorphic both when compiled and when interpreted
: row-&& ( -- ? )
f t { [ drop dup ] } 1&& nip ;
[ f ] [ row-&& ] unit-test
[ f ] [ \ row-&& def>> call ] unit-test
: row-|| ( -- ? )
f t { [ drop dup ] } 1|| nip ;
[ f ] [ row-|| ] unit-test
[ f ] [ \ row-|| def>> call ] unit-test

14
basis/combinators/short-circuit/short-circuit.factor
View File

@ -1,11 +1,19 @@
USING: kernel combinators quotations arrays sequences assocs
generalizations macros fry ;
generalizations macros fry math ;
IN: combinators.short-circuit
<PRIVATE
MACRO: keeping ( n quot -- quot' )
swap dup 1 +
'[ _ _ nkeep _ nrot ] ;
PRIVATE>
MACRO: n&& ( quots n -- quot )
[
[ [ f ] ] 2dip swap [
[ '[ drop _ ndup @ dup not ] ]
[ '[ drop _ _ keeping dup not ] ]
[ drop '[ drop _ ndrop f ] ]
2bi 2array
] with map
@ -27,7 +35,7 @@ PRIVATE>
MACRO: n|| ( quots n -- quot )
[
[ [ f ] ] 2dip swap [
[ '[ drop _ ndup @ dup ] ]
[ '[ drop _ _ keeping dup ] ]
[ drop '[ _ nnip ] ]
2bi 2array
] with map

3
basis/core-foundation/arrays/arrays.factor
View File

@ -15,7 +15,8 @@ FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* v
FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
: CF>array ( alien -- array )
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
dup CFArrayGetCount
[ CFArrayGetValueAtIndex ] with { } map-integers ;
: <CFArray> ( seq -- alien )
f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable

2
basis/debugger/debugger.factor
View File

@ -50,7 +50,7 @@ M: string error. print ;
: restart. ( restart n -- )
[
1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
name>> %
] "" make print ;

6
basis/help/apropos/apropos.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry help.markup help.topics io
kernel make math math.parser namespaces sequences sorting
@ -19,6 +19,8 @@ TUPLE: more-completions seq ;
CONSTANT: max-completions 5
M: more-completions valid-article? drop t ;
M: more-completions article-title
seq>> length number>string " results" append ;
@ -60,6 +62,8 @@ TUPLE: apropos search ;
C: <apropos> apropos
M: apropos valid-article? drop t ;
M: apropos article-title
search>> "Search results for “" "”" surround ;

4
basis/help/help.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io io.styles kernel namespaces make
parser prettyprint sequences words words.symbol assocs
@ -48,6 +48,8 @@ M: predicate word-help* drop \ $predicate ;
: all-errors ( -- seq )
all-words [ error? ] filter sort-articles ;
M: word valid-article? drop t ;
M: word article-name name>> ;
M: word article-title

5
basis/help/home/home.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays compiler.units fry hashtables help.topics io
kernel math namespaces sequences sets help.vocabs
@ -21,7 +21,8 @@ M: apropos add-recent-where recent-searches ;
M: object add-recent-where f ;
: $recent ( element -- )
first get reverse [ nl ] [ 1array $pretty-link ] interleave ;
first get [ valid-article? ] filter <reversed>
[ nl ] [ 1array $pretty-link ] interleave ;
: $recent-searches ( element -- )
drop recent-searches get [ <$link> ] map $list ;

7
basis/help/topics/topics.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.x
USING: accessors arrays definitions generic assocs
io kernel namespaces make prettyprint prettyprint.sections
@ -38,6 +38,7 @@ SYMBOL: article-xref
article-xref [ H{ } clone ] initialize
GENERIC: valid-article? ( topic -- ? )
GENERIC: article-name ( topic -- string )
GENERIC: article-title ( topic -- string )
GENERIC: article-content ( topic -- content )
@ -49,6 +50,7 @@ TUPLE: article title content loc ;
: <article> ( title content -- article )
f \ article boa ;
M: article valid-article? drop t ;
M: article article-name title>> ;
M: article article-title title>> ;
M: article article-content content>> ;
@ -61,12 +63,14 @@ M: no-article summary
: article ( name -- article )
articles get ?at [ no-article ] unless ;
M: object valid-article? articles get key? ;
M: object article-name article article-name ;
M: object article-title article article-title ;
M: object article-content article article-content ;
M: object article-parent article-xref get at ;
M: object set-article-parent article-xref get set-at ;
M: link valid-article? name>> valid-article? ;
M: link article-name name>> article-name ;
M: link article-title name>> article-title ;
M: link article-content name>> article-content ;
@ -74,6 +78,7 @@ M: link article-parent name>> article-parent ;
M: link set-article-parent name>> set-article-parent ;
! Special case: f help
M: f valid-article? drop t ;
M: f article-name drop \ f article-name ;
M: f article-title drop \ f article-title ;
M: f article-content drop \ f article-content ;

8
basis/help/vocabs/vocabs.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
@ -278,6 +278,8 @@ INSTANCE: vocab topic
INSTANCE: vocab-link topic
M: vocab-spec valid-article? drop t ;
M: vocab-spec article-title vocab-name " vocabulary" append ;
M: vocab-spec article-name vocab-name ;
@ -289,6 +291,8 @@ M: vocab-spec article-parent drop "vocab-index" ;
M: vocab-tag >link ;
M: vocab-tag valid-article? drop t ;
M: vocab-tag article-title
name>> "Vocabularies tagged “" "”" surround ;
@ -303,6 +307,8 @@ M: vocab-tag summary article-title ;
M: vocab-author >link ;
M: vocab-author valid-article? drop t ;
M: vocab-author article-title
name>> "Vocabularies by " prepend ;

9
basis/json/reader/reader.factor
View File

@ -1,18 +1,13 @@
! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators io io.streams.string json
kernel math math.floats.parser math.parser prettyprint sequences
strings vectors ;
kernel math math.parser prettyprint sequences strings vectors ;
IN: json.reader
<PRIVATE
: value ( char -- num char )
1string " \t\r\n,:}]" read-until
[
append
[ string>float ]
[ [ "eE." index ] any? [ >integer ] unless ] bi
] dip ;
[ append string>number ] dip ;
DEFER: j-string

14
basis/math/floats/parser/parser.factor
View File

@ -1,14 +0,0 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax ;
IN: math.floats.parser
<PRIVATE
LIBRARY: libc
FUNCTION: double strtod ( char* nptr, char** endptr ) ;
PRIVATE>
: string>float ( str -- n/f ) f <void*> strtod ;

27
basis/math/functions/functions.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel math.constants math.private math.bits
math.libm combinators math.order sequences ;
math.libm combinators fry math.order sequences ;
IN: math.functions
: >fraction ( a/b -- a b )
@ -13,12 +13,13 @@ IN: math.functions
GENERIC: sqrt ( x -- y ) foldable
M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline
>float dup 0.0 <
[ neg fsqrt [ 0.0 ] dip rect> ] [ fsqrt ] if ; inline
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
dup 0 = [ 1 ] [
0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
[ 0 ] dip [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
] if ; inline
<PRIVATE
@ -26,13 +27,13 @@ M: real sqrt
GENERIC# ^n 1 ( z w -- z^w ) foldable
: (^n) ( z w -- z^w )
make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
make-bits 1 [ [ over * ] when [ sq ] dip ] reduce nip ; inline
M: integer ^n
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
M: ratio ^n
[ >fraction ] dip [ ^n ] curry bi@ / ;
[ >fraction ] dip '[ _ ^n ] bi@ / ;
M: float ^n (^n) ;
@ -62,7 +63,7 @@ M: float exp fexp ; inline
M: real exp >float exp ; inline
M: complex exp >rect swap exp swap polar> ; inline
M: complex exp >rect [ exp ] dip polar> ; inline
<PRIVATE
@ -84,10 +85,9 @@ M: complex exp >rect swap exp swap polar> ; inline
: 0^ ( x -- z )
[ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline
: (^mod) ( n x y -- z )
make-bits 1 [
[ dupd * pick mod ] when [ sq over mod ] dip
] reduce 2nip ; inline
: (^mod) ( x y n -- z )
[ make-bits 1 ] dip dup
'[ [ over * _ mod ] when [ sq _ mod ] dip ] reduce nip ; inline
: (gcd) ( b a x y -- a d )
over zero? [
@ -125,11 +125,8 @@ ERROR: non-trivial-divisor n ;
[ non-trivial-divisor ] if ; foldable
: ^mod ( x y n -- z )
over 0 < [
[ [ neg ] dip ^mod ] keep mod-inv
] [
-rot (^mod)
] if ; foldable
over 0 <
[ [ [ neg ] dip ^mod ] keep mod-inv ] [ (^mod) ] if ; foldable
GENERIC: absq ( x -- y ) foldable

16
basis/ui/backend/cocoa/tools/tools.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax cocoa cocoa.nibs cocoa.application
cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.runtime
cocoa.subclassing core-foundation core-foundation.strings
help.topics kernel memory namespaces parser system ui
ui.tools.browser ui.tools.listener ui.backend.cocoa eval
locals vocabs.refresh ;
locals listener vocabs.refresh ;
FROM: alien.c-types => int void ;
IN: ui.backend.cocoa.tools
@ -82,12 +82,20 @@ CLASS: {
"evalInListener:userData:error:"
void
{ id SEL id id id }
[ nip [ eval-listener f ] do-service 2drop ]
[
nip
[ eval-listener f ] do-service
2drop
]
} {
"evalToString:userData:error:"
void
{ id SEL id id id }
[ nip [ eval>string ] do-service 2drop ]
[
nip
[ [ (eval>string) ] with-interactive-vocabs ] do-service
2drop
]
} ;
: register-services ( -- )

20
basis/ui/text/core-text/core-text.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors alien core-graphics.types core-text
core-text.fonts kernel hashtables namespaces sequences
ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl
opengl.textures destructors combinators core-foundation
core-foundation.strings math math.vectors init colors colors.constants
cache arrays images ;
core-text.fonts kernel hashtables namespaces sequences ui.text
ui.text.private destructors combinators core-foundation
core-foundation.strings math math.vectors init colors
colors.constants cache arrays images ;
IN: ui.text.core-text
SINGLETON: core-text-renderer
@ -18,13 +17,8 @@ M: core-text-renderer string-dim
M: core-text-renderer flush-layout-cache
cached-lines get purge-cache ;
: rendered-line ( font string -- texture )
world get world-text-handle [
cached-line [ image>> ] [ loc>> ] bi <texture>
] 2cache ;
M: core-text-renderer draw-string ( font string -- )
rendered-line draw-texture ;
M: core-text-renderer string>image ( font string -- image loc )
cached-line [ image>> ] [ loc>> ] bi ;
M: core-text-renderer x>offset ( x font string -- n )
[ 2drop 0 ] [

17
basis/ui/text/pango/pango.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types assocs cache kernel math math.vectors
namespaces opengl.textures pango.cairo pango.layouts ui.gadgets.worlds
ui.text ui.text.private pango sequences ;
USING: accessors assocs cache kernel math math.vectors
namespaces pango.cairo pango.layouts ui.text ui.text.private
pango sequences ;
IN: ui.text.pango
SINGLETON: pango-renderer
@ -14,13 +14,8 @@ M: pango-renderer string-dim
M: pango-renderer flush-layout-cache
cached-layouts get purge-cache ;
: rendered-layout ( font string -- texture )
world get world-text-handle [
cached-layout [ image>> ] [ text-position vneg ] bi <texture>
] 2cache ;
M: pango-renderer draw-string ( font string -- )
rendered-layout draw-texture ;
M: pango-renderer string>image ( font string -- image loc )
cached-layout [ image>> ] [ text-position vneg ] bi ;
M: pango-renderer x>offset ( x font string -- n )
cached-layout swap x>line-offset ;

8
basis/ui/text/text-docs.factor
View File

@ -1,5 +1,5 @@
IN: ui.text
USING: help.markup help.syntax kernel ui.text.private strings math fonts ;
USING: help.markup help.syntax kernel ui.text.private strings math fonts images ;
HELP: string-width
{ $values { "font" font } { "string" string } { "w" "a positive integer" } }
@ -48,6 +48,10 @@ HELP: line-metrics
{ $values { "font" font } { "string" string } { "metrics" line-metrics } }
{ $contract "Outputs a " { $link metrics } " object with text measurements." } ;
HELP: string>image
{ $values { "font" font } { "string" string } { "image" image } { "loc" "a pair of real numbers" } }
{ $description "Renders a line of text into an image." } ;
ARTICLE: "text-rendering" "Rendering text"
"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X, Uniscribe on Windows and Pango on X11."
{ $subsections "fonts" }
@ -64,7 +68,7 @@ ARTICLE: "text-rendering" "Rendering text"
offset>x
}
"Rendering text:"
{ $subsections draw-text }
{ $subsections draw-text string>image }
"Low-level text protocol for UI backends:"
{ $subsections
string-width

5
basis/ui/text/text-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test ui.text fonts math accessors kernel sequences ;
USING: tools.test ui.text images fonts math arrays accessors kernel
sequences ;
IN: ui.text.tests
[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
@ -20,3 +21,5 @@ IN: ui.text.tests
[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test
[ t ] [ serif-font "Hello world" string>image [ image? ] [ pair? ] bi* and ] unit-test

26
basis/ui/text/text.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays sequences math math.order cache opengl
opengl.gl strings fonts colors accessors namespaces
ui.gadgets.worlds ;
USING: kernel arrays assocs sequences math math.order cache
opengl opengl.gl opengl.textures strings fonts colors accessors
namespaces ui.gadgets.worlds ;
IN: ui.text
<PRIVATE
@ -29,8 +29,6 @@ M: object string-width string-dim first ;
M: object string-height string-dim second ;
HOOK: draw-string font-renderer ( font string -- )
HOOK: free-fonts font-renderer ( world -- )
: combine-text-dim ( dim1 dim2 -- dim3 )
@ -59,6 +57,22 @@ HOOK: font-metrics font-renderer ( font -- metrics )
HOOK: line-metrics font-renderer ( font string -- metrics )
HOOK: string>image font-renderer ( font string -- image loc )
<PRIVATE
: string-empty? ( obj -- ? )
dup selection? [ string>> ] when empty? ;
: draw-string ( font string -- )
dup string-empty? [ 2drop ] [
world get world-text-handle
[ string>image <texture> ] 2cache
draw-texture
] if ;
PRIVATE>
GENERIC: draw-text ( font text -- )
M: string draw-text draw-string ;

17
basis/ui/text/uniscribe/uniscribe.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache kernel math math.vectors sequences fonts
namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds
windows.uniscribe ;
USING: accessors assocs cache kernel math math.vectors sequences
fonts namespaces ui.text ui.text.private windows.uniscribe ;
IN: ui.text.uniscribe
SINGLETON: uniscribe-renderer
@ -14,14 +13,8 @@ M: uniscribe-renderer string-dim
M: uniscribe-renderer flush-layout-cache
cached-script-strings get purge-cache ;
: rendered-script-string ( font string -- texture )
world get world-text-handle
[ cached-script-string image>> { 0 0 } <texture> ]
2cache ;
M: uniscribe-renderer draw-string ( font string -- )
dup dup selection? [ string>> ] when empty?
[ 2drop ] [ rendered-script-string draw-texture ] if ;
M: uniscribe-renderer string>image ( font string -- image loc )
cached-script-string image>> { 0 0 } ;
M: uniscribe-renderer x>offset ( x font string -- n )
[ 2drop 0 ] [

6
core/classes/algebra/algebra-tests.factor
View File

@ -211,12 +211,6 @@ MIXIN: empty-mixin
[ f ] [ null class-not null class= ] unit-test
! class<=>
[ +lt+ ] [ sequence object class<=> ] unit-test
[ +gt+ ] [ object sequence class<=> ] unit-test
[ +eq+ ] [ integer integer class<=> ] unit-test
! smallest-class etc
[ real ] [ { real sequence } smallest-class ] unit-test
[ real ] [ { sequence real } smallest-class ] unit-test

7
core/classes/algebra/algebra.factor
View File

@ -57,13 +57,6 @@ M: anonymous-complement classoid? class>> classoid? ;
[ [ rank-class ] bi@ < ]
} cond ;
: class<=> ( first second -- ? )
{
{ [ 2dup class<= not ] [ 2drop +gt+ ] }
{ [ 2dup swap class<= not ] [ 2drop +lt+ ] }
[ [ rank-class ] bi@ <=> ]
} cond ;
: class= ( first second -- ? )
[ class<= ] [ swap class<= ] 2bi and ;

2
core/math/integers/integers-tests.factor
View File

@ -220,7 +220,7 @@ unit-test
1 random zero? [ >bignum ] when ;
[ t ] [
1000 [
10000 [
drop
random-integer
random-integer

30
core/math/integers/integers.factor
View File

@ -119,30 +119,26 @@ M: bignum (log2) bignum-log2 ; inline
: scale-denonimator ( den -- scaled-den scale' )
dup twos neg [ shift ] keep ; inline
: pre-scale ( num den -- scale shifted-num scaled-den )
: pre-scale ( num den -- mantissa den' scale )
2dup [ log2 ] bi@ -
[ neg 54 + shift ] [ [ scale-denonimator ] dip + ] bi-curry bi*
-rot ; inline
[ neg 54 + shift ] [ [ scale-denonimator ] dip + ] bi-curry bi* ; inline
! Second step: loop
: shift-mantissa ( scale mantissa -- scale' mantissa' )
[ 1 + ] [ 2/ ] bi* ; inline
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
[ [ shift-mantissa ] dip ]
while /mod ; inline
: /f-loop ( mantissa den scale -- fraction-and-guard rem scale' )
[ 2over /i log2 53 > ]
[ [ 2/ ] [ ] [ 1 + ] tri* ] while
[ /mod ] dip ; inline
! Third step: post-scaling
: unscaled-float ( mantissa -- n )
52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline
: scale-float ( scale mantissa -- float' )
[ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
: scale-float ( mantissa scale -- float' )
dup 0 < [ neg 2^ recip ] [ 2^ ] if * ; inline
: post-scale ( scale mantissa -- n )
2/ dup log2 52 > [ shift-mantissa ] when
unscaled-float scale-float ; inline
: post-scale ( mantissa scale -- n )
[ 2/ ] dip over log2 52 > [ [ 2/ ] [ 1 + ] bi* ] when
[ unscaled-float ] dip scale-float ; inline
! Main word
: /f-abs ( m n -- f )
@ -153,8 +149,8 @@ M: bignum (log2) bignum-log2 ; inline
drop 1/0.
] [
pre-scale
/f-loop over odd?
[ zero? [ 1 + ] unless ] [ drop ] if
/f-loop
[ over odd? [ zero? [ 1 + ] unless ] [ drop ] if ] dip
post-scale
] if-zero
] if ; inline

11
core/sequences/sequences-tests.factor
View File

@ -1,4 +1,4 @@
USING: arrays kernel math namespaces sequences kernel.private
USING: arrays kernel math math.order namespaces sequences kernel.private
sequences.private strings sbufs tools.test vectors assocs
generic vocabs.loader ;
IN: sequences.tests
@ -300,3 +300,12 @@ USE: make
[ t ] [ 0 array-capacity? ] unit-test
[ f ] [ -1 array-capacity? ] unit-test
[ +lt+ ] [ { 0 0 0 } { 1 1 1 } <=> ] unit-test
[ +lt+ ] [ { 0 0 0 } { 0 1 1 } <=> ] unit-test
[ +lt+ ] [ { 0 0 0 } { 0 0 0 0 } <=> ] unit-test
[ +gt+ ] [ { 1 1 1 } { 0 0 0 } <=> ] unit-test
[ +gt+ ] [ { 0 1 1 } { 0 0 0 } <=> ] unit-test
[ +gt+ ] [ { 0 0 0 0 } { 0 0 0 } <=> ] unit-test
[ +eq+ ] [ { } { } <=> ] unit-test
[ +eq+ ] [ { 1 2 3 } { 1 2 3 } <=> ] unit-test

18
core/sequences/sequences.factor
View File

@ -91,6 +91,8 @@ M: sequence set-nth-unsafe set-nth ; inline
: change-nth-unsafe ( i seq quot -- )
[ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
PRIVATE>
! The f object supports the sequence protocol trivially
M: f length drop 0 ; inline
M: f nth-unsafe nip ; inline
@ -98,20 +100,18 @@ M: f like drop [ f ] when-empty ; inline
INSTANCE: f immutable-sequence
PRIVATE>
! In the future, this will replace integer sequences
! Integer sequences
TUPLE: iota { n integer read-only } ;
: iota ( n -- iota ) \ iota boa ; inline
<PRIVATE
M: iota length n>> ; inline
M: iota nth-unsafe drop ; inline
INSTANCE: iota immutable-sequence
<PRIVATE
: first-unsafe ( seq -- first )
0 swap nth-unsafe ; inline
@ -586,13 +586,13 @@ PRIVATE>
[ empty? not ] filter ;
: mismatch ( seq1 seq2 -- i )
[ min-length iota ] 2keep
[ min-length ] 2keep
[ 2nth-unsafe = not ] 2curry
find drop ; inline
find-integer ; inline
M: sequence <=>
2dup mismatch
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
[ mismatch ] 2keep pick
[ 2nth-unsafe <=> ] [ [ length ] compare nip ] if ;
: sequence= ( seq1 seq2 -- ? )
2dup [ length ] bi@ =

4
extra/game/models/collada/collada.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2010 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs grouping hashtables kernel locals
math math.floats.parser math.parser sequences sequences.deep
math math.parser sequences sequences.deep
specialized-arrays.instances.alien.c-types.float
specialized-arrays.instances.alien.c-types.uint splitting xml
xml.data xml.traversal math.order namespaces combinators images
@ -23,7 +23,7 @@ SYMBOLS: up-axis unit-ratio ;
" \t\n" split harvest [ string>number ] map ;
: string>floats ( string -- float-seq )
" \t\n" split harvest [ string>float ] map ;
" \t\n" split harvest [ string>number ] map ;
: x/ ( tag child-name -- child-tag )
[ tag-named ]

6
extra/game/models/obj/obj-docs.factor
View File

@ -22,9 +22,9 @@ HELP: md
{ $values { "material-dictionary" assoc } }
{ $description "Convenience word for accessing the material dictionary while parsing primitives. " } ;
HELP: strings>floats
{ $values { "strings" sequence } { "floats" sequence } }
{ $description "Convert a sequence of strings to a sequence of floats." } ;
HELP: strings>numbers
{ $values { "strings" sequence } { "numbers" sequence } }
{ $description "Convert a sequence of strings to a sequence of numbers." } ;
HELP: strings>faces
{ $values { "strings" sequence } { "faces" sequence } }

48
extra/game/models/obj/obj.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2010 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: io io.encodings.ascii math.parser math.floats.parser
sequences splitting kernel assocs io.files combinators
math.order math namespaces arrays sequences.deep accessors
USING: io io.encodings.ascii math.parser sequences splitting
kernel assocs io.files combinators math.order math namespaces
arrays sequences.deep accessors
specialized-arrays.instances.alien.c-types.float
specialized-arrays.instances.alien.c-types.uint game.models
game.models.util gpu.shaders images game.models.loader
@ -36,8 +36,8 @@ TUPLE: material
: cm ( -- current-material ) current-material get ; inline
: md ( -- material-dictionary ) material-dictionary get ; inline
: strings>floats ( strings -- floats )
[ string>float ] map ;
: strings>numbers ( strings -- numbers )
[ string>number ] map ;
: strings>faces ( strings -- faces )
[ "/" split [ string>number ] map ] map ;
@ -54,22 +54,22 @@ TUPLE: material
[ material new swap >>name current-material set ]
[ cm swap md set-at ] bi
] }
{ "Ka" [ 3 head [ string>float ] map cm (>>ambient-reflectivity) ] }
{ "Kd" [ 3 head [ string>float ] map cm (>>diffuse-reflectivity) ] }
{ "Ks" [ 3 head [ string>float ] map cm (>>specular-reflectivity) ] }
{ "Tf" [ 3 head [ string>float ] map cm (>>transmission-filter) ] }
{ "d" [ first string>float cm (>>dissolve) ] }
{ "Ns" [ first string>float cm (>>specular-exponent) ] }
{ "Ni" [ first string>float cm (>>refraction-index) ] }
{ "map_Ka" [ first cm (>>ambient-map) ] }
{ "map_Kd" [ first cm (>>diffuse-map) ] }
{ "map_Ks" [ first cm (>>specular-map) ] }
{ "map_Ns" [ first cm (>>specular-exponent-map) ] }
{ "map_d" [ first cm (>>dissolve-map) ] }
{ "map_bump" [ first cm (>>bump-map) ] }
{ "bump" [ first cm (>>bump-map) ] }
{ "disp" [ first cm (>>displacement-map) ] }
{ "refl" [ first cm (>>reflection-map) ] }
{ "Ka" [ 3 head strings>numbers cm (>>ambient-reflectivity) ] }
{ "Kd" [ 3 head strings>numbers cm (>>diffuse-reflectivity) ] }
{ "Ks" [ 3 head strings>numbers cm (>>specular-reflectivity) ] }
{ "Tf" [ 3 head strings>numbers cm (>>transmission-filter) ] }
{ "d" [ first string>number cm (>>dissolve) ] }
{ "Ns" [ first string>number cm (>>specular-exponent) ] }
{ "Ni" [ first string>number cm (>>refraction-index) ] }
{ "map_Ka" [ first cm (>>ambient-map) ] }
{ "map_Kd" [ first cm (>>diffuse-map) ] }
{ "map_Ks" [ first cm (>>specular-map) ] }
{ "map_Ns" [ first cm (>>specular-exponent-map) ] }
{ "map_d" [ first cm (>>dissolve-map) ] }
{ "map_bump" [ first cm (>>bump-map) ] }
{ "bump" [ first cm (>>bump-map) ] }
{ "disp" [ first cm (>>displacement-map) ] }
{ "refl" [ first cm (>>reflection-map) ] }
[ 2drop ]
} case
] unless-empty ;
@ -137,9 +137,9 @@ VERTEX-FORMAT: obj-vertex-format
[ rest ] [ first ] bi
{
{ "mtllib" [ first read-mtl material-dictionary set ] }
{ "v" [ strings>floats 3 head vp [ push* ] change ] }
{ "vt" [ strings>floats 2 head vt [ push* ] change ] }
{ "vn" [ strings>floats 3 head vn [ push* ] change ] }
{ "v" [ strings>numbers 3 head vp [ push* ] change ] }
{ "vt" [ strings>numbers 2 head vt [ push* ] change ] }
{ "vn" [ strings>numbers 3 head vn [ push* ] change ] }
{ "usemtl" [ push-current-model first md at current-material set ] }
{ "f" [ strings>faces face>aos [ [ current-model [ push* ] change ] each ] each ] }
[ 2drop ]

6
extra/mason/release/archive/archive.factor
View File

@ -9,14 +9,14 @@ IN: mason.release.archive
: base-name ( -- string )
[ "factor-" % platform % "-" % stamp get % ] "" make ;
: extension ( -- extension )
target-os get {
: extension ( os -- extension )
{
{ "winnt" [ ".zip" ] }
{ "macosx" [ ".dmg" ] }
[ drop ".tar.gz" ]
} case ;
: archive-name ( -- string ) base-name extension append ;
: archive-name ( -- string ) base-name target-os get extension append ;
:: make-windows-archive ( archive-name -- )
{ "zip" "-r" archive-name "factor" } short-running-process ;

0
basis/math/floats/parser/authors.txt → extra/mason/server/authors.txt
View File

0
extra/mason/notify/server/authors.txt → extra/mason/server/notify/authors.txt
View File

53
extra/mason/notify/server/server.factor → extra/mason/server/notify/notify.factor
View File

@ -1,46 +1,9 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.smart command-line db
db.sqlite db.tuples db.types io io.encodings.utf8 io.files
present kernel namespaces sequences calendar ;
IN: mason.notify.server
CONSTANT: +starting+ "starting"
CONSTANT: +make-vm+ "make-vm"
CONSTANT: +boot+ "boot"
CONSTANT: +test+ "test"
CONSTANT: +clean+ "status-clean"
CONSTANT: +dirty+ "status-dirty"
CONSTANT: +error+ "status-error"
TUPLE: builder
host-name os cpu
clean-git-id clean-timestamp
last-release release-git-id
last-git-id last-timestamp last-report
current-git-id current-timestamp
status ;
builder "BUILDERS" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
{ "clean-git-id" "CLEAN_GIT_ID" TEXT }
{ "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
{ "last-release" "LAST_RELEASE" TEXT }
{ "release-git-id" "RELEASE_GIT_ID" TEXT }
{ "last-git-id" "LAST_GIT_ID" TEXT }
{ "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
{ "last-report" "LAST_REPORT" TEXT }
{ "current-git-id" "CURRENT_GIT_ID" TEXT }
! Can't name it CURRENT_TIMESTAMP because of bug in db library
{ "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
{ "status" "STATUS" TEXT }
} define-persistent
USING: accessors calendar combinators combinators.smart
command-line db.tuples io io.encodings.utf8 io.files kernel
mason.server namespaces present sequences ;
IN: mason.server.notify
SYMBOLS: host-name target-os target-cpu message message-arg ;
@ -96,13 +59,11 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
{ "release" [ message-arg get release ] }
} case ;
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
: handle-update ( command-line timestamp -- )
mason-db [
[
[ parse-args find-builder ] dip >>current-timestamp
[ update-builder ] [ update-tuple ] bi
] with-db ;
] with-mason-db ;
CONSTANT: log-file "resource:mason.log"

1
extra/mason/server/release/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

81
extra/mason/server/release/release.factor Normal file
View File

@ -0,0 +1,81 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar db db.tuples grouping io
io.encodings.ascii io.launcher kernel locals make
mason.release.archive mason.server namespaces sequences ;
IN: mason.server.release
! Host to upload binary package to.
SYMBOL: upload-host
! Username to log in.
SYMBOL: upload-username
! Directory with binary packages.
SYMBOL: upload-directory
: platform ( builder -- string )
[ os>> ] [ cpu>> ] bi "-" glue ;
: package-name ( builder -- string )
[ platform ] [ last-release>> ] bi "/" glue ;
: release-name ( version builder -- string )
[
"releases/" %
[ platform % "/" % ]
[ "factor-" % platform % "-" % % ]
[ os>> extension % ]
tri
] "" make ;
: release-command ( version builder -- command )
[
"ln -s " %
[ nip package-name % " " % ] [ release-name % ] 2bi
] { } make ;
TUPLE: release
host-name os cpu
last-release release-git-id ;
:: <release> ( version builder -- release )
release new
builder host-name>> >>host-name
builder os>> >>os
builder cpu>> >>cpu
builder release-git-id>> >>release-git-id
version builder release-name >>last-release ;
: execute-on-server ( string -- )
[ "ssh" , upload-host get , "-l" , upload-username get , ] { } make
<process>
swap >>command
30 seconds >>timeout
ascii [ write ] with-process-writer ;
: release-script ( version builders -- string )
upload-directory get "cd " "\n" surround prepend
[ release-command ] with map "\n" join ;
: create-releases ( version builders -- )
release-script execute-on-server ;
: update-releases ( version builders -- )
[
release new delete-tuples
[ <release> insert-tuple ] with each
] with-transaction ;
: check-releases ( builders -- )
[ release-git-id>> ] map all-equal?
[ "Not all builders are up to date" throw ] unless ;
: do-release ( version -- )
[
builder new select-tuples
[ nip check-releases ]
[ create-releases ]
[ update-releases ]
2tri
] with-mason-db ;

46
extra/mason/server/server.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.sqlite db.tuples db.types kernel ;
IN: mason.server
CONSTANT: +starting+ "starting"
CONSTANT: +make-vm+ "make-vm"
CONSTANT: +boot+ "boot"
CONSTANT: +test+ "test"
CONSTANT: +clean+ "status-clean"
CONSTANT: +dirty+ "status-dirty"
CONSTANT: +error+ "status-error"
TUPLE: builder
host-name os cpu
clean-git-id clean-timestamp
last-release release-git-id
last-git-id last-timestamp last-report
current-git-id current-timestamp
status ;
builder "BUILDERS" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
{ "clean-git-id" "CLEAN_GIT_ID" TEXT }
{ "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
{ "last-release" "LAST_RELEASE" TEXT }
{ "release-git-id" "RELEASE_GIT_ID" TEXT }
{ "last-git-id" "LAST_GIT_ID" TEXT }
{ "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
{ "last-report" "LAST_REPORT" TEXT }
{ "current-git-id" "CURRENT_GIT_ID" TEXT }
! Can't name it CURRENT_TIMESTAMP because of bug in db library
{ "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
{ "status" "STATUS" TEXT }
} define-persistent
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
: with-mason-db ( quot -- )
[ mason-db ] dip with-db ; inline

5
extra/webapps/mason/mason.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators db db.tuples furnace.actions
http.server.responses http.server.dispatchers kernel mason.platform
mason.notify.server mason.report math.order sequences sorting
mason.server mason.report math.order sequences sorting
splitting xml.syntax xml.writer io.pathnames io.encodings.utf8
io.files present validators html.forms furnace.db urls ;
FROM: assocs => at keys values ;
@ -181,4 +181,3 @@ CONSTANT: cpus
<download-binary-action> "download" add-responder
<download-grid-action> "grid" add-responder
mason-db <db-persistence> ;

1
misc/fuel/README
View File

@ -99,6 +99,7 @@ beast.
|-----------------+------------------------------------------------------------|
| C-cz | switch to listener (run-factor) |
| C-co | cycle between code, tests and docs files |
| C-ct | run the unit tests for a vocabulary |
| C-cr | switch to listener and refresh all loaded vocabs |
| C-cs | switch to other factor buffer (fuel-switch-to-buffer) |
| C-x4s | switch to other factor buffer in other window |

6
misc/fuel/fuel-completion.el
View File

@ -190,13 +190,13 @@ terminates a current completion."
(defvar fuel-completion--vocab-history nil)
(defun fuel-completion--read-vocab (refresh)
(defun fuel-completion--read-vocab (refresh &optional init-input)
(let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)
(vocabs (fuel-completion--vocabs refresh))
(prompt "Vocabulary name: "))
(if vocabs
(completing-read prompt vocabs nil nil nil fuel-completion--vocab-history)
(read-string prompt nil fuel-completion--vocab-history))))
(completing-read prompt vocabs nil nil init-input fuel-completion--vocab-history)
(read-string prompt init-input fuel-completion--vocab-history))))
(defun fuel-completion--complete-symbol ()
"Complete the symbol at point.

7
misc/fuel/fuel-listener.el
View File

@ -192,6 +192,13 @@ With prefix, you're teletransported to the listener's buffer."
(comint-send-string nil "\"Refreshing loaded vocabs...\" write nl flush")
(comint-send-string nil " refresh-all \"Done!\" write nl flush\n")))
(defun fuel-test-vocab (vocab)
"Run the unit tests for the specified vocabulary."
(interactive (list (fuel-completion--read-vocab nil (fuel-syntax--current-vocab))))
(comint-send-string (fuel-listener--process)
(concat "\"" vocab "\" reload nl flush\n"
"\"" vocab "\" test nl flush\n")))
;;; Completion support

1
misc/fuel/fuel-mode.el
View File

@ -191,6 +191,7 @@ interacting with a factor listener is at your disposal.
(fuel-mode--key-1 ?k 'fuel-run-file)
(fuel-mode--key-1 ?l 'fuel-run-file)
(fuel-mode--key-1 ?r 'fuel-refresh-all)
(fuel-mode--key-1 ?t 'fuel-test-vocab)
(fuel-mode--key-1 ?z 'run-factor)
(fuel-mode--key-1 ?s 'fuel-switch-to-buffer)
(define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window)

22
misc/fuel/fuel-syntax.el
View File

@ -50,7 +50,8 @@
"DEFER:"
"EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
"f" "FORGET:" "FROM:" "FUNCTION:"
"GENERIC#" "GENERIC:"
"GAME:" "GENERIC#" "GENERIC:"
"GLSL-SHADER:" "GLSL-PROGRAM:"
"HELP:" "HEX:" "HOOK:"
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
"LIBRARY:"
@ -60,10 +61,10 @@
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"QUALIFIED-WITH:" "QUALIFIED:"
"read-only" "RENAME:" "REQUIRE:" "REQUIRES:"
"SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
"TUPLE:" "t" "t?" "TYPEDEF:"
"UNION:" "USE:" "USING:"
"VARS:"))
"SINGLETON:" "SINGLETONS:" "SLOT:" "STRING:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
"TUPLE:" "t" "t?" "TYPEDEF:" "TYPED:" "TYPED::"
"UNIFORM-TUPLE:" "UNION:" "USE:" "USING:"
"VARS:" "VERTEX-FORMAT:"))
(defconst fuel-syntax--parsing-words-regex
(regexp-opt fuel-syntax--parsing-words 'words))
@ -110,7 +111,7 @@
(format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
(regexp-opt
'(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
"SYMBOL" "SYNTAX" "RENAME"))))
"SYMBOL" "SYNTAX" "TYPED" "RENAME"))))
(defconst fuel-syntax--alias-definition-regex
"^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
@ -159,8 +160,11 @@
"MEMO" "MEMO:" "METHOD"
"SYNTAX"
"PREDICATE" "PRIMITIVE"
"STRUCT" "TAG" "TUPLE" "UNION-STRUCT"
"UNION"))
"STRUCT" "TAG" "TUPLE"
"TYPED" "TYPED:"
"UNIFORM-TUPLE"
"UNION-STRUCT" "UNION"
"VERTEX-FORMAT"))
(defconst fuel-syntax--no-indent-def-starts '("ARTICLE"
"HELP"
@ -185,7 +189,7 @@
"CONSTANT:" "C:"
"DEFER:"
"FORGET:"
"GENERIC:" "GENERIC#"
"GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"
"HEX:" "HOOK:"
"IN:" "INSTANCE:"
"LIBRARY:"