Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
09a4080772
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ M: string error. print ;
|
|||
|
||||
: restart. ( restart n -- )
|
||||
[
|
||||
1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
|
||||
1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
|
||||
name>> %
|
||||
] "" make print ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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 ] [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ] [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -220,7 +220,7 @@ unit-test
|
|||
1 random zero? [ >bignum ] when ;
|
||||
|
||||
[ t ] [
|
||||
1000 [
|
||||
10000 [
|
||||
drop
|
||||
random-integer
|
||||
random-integer
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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@ =
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 |
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
Loading…
Reference in New Issue