Merge branch 'master' of git://factorcode.org/git/factor
sheeple
commit
6dcb6b9c95
|
|
@ -59,10 +59,38 @@ slots ;
|
|||
|
||||
: <value-info> ( -- info ) \ value-info new ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
#! Delegation.
|
||||
all-slots rest-slice
|
||||
[ read-only>> [ drop f ] unless ] 2map
|
||||
{ f f } prepend ;
|
||||
|
||||
DEFER: <literal-info>
|
||||
|
||||
: init-literal-info ( info -- info )
|
||||
#! Delegation.
|
||||
dup literal>> class >>class
|
||||
dup literal>> dup real? [ [a,a] >>interval ] [
|
||||
[ [-inf,inf] >>interval ] dip
|
||||
{
|
||||
{ [ dup complex? ] [
|
||||
[ real-part <literal-info> ]
|
||||
[ imaginary-part <literal-info> ] bi
|
||||
2array >>slots
|
||||
] }
|
||||
{ [ dup tuple? ] [
|
||||
[
|
||||
tuple-slots rest-slice
|
||||
[ <literal-info> ] map
|
||||
] [ class ] bi read-only-slots >>slots
|
||||
] }
|
||||
[ drop ]
|
||||
} cond
|
||||
] if ; inline
|
||||
|
||||
: init-value-info ( info -- info )
|
||||
dup literal?>> [
|
||||
dup literal>> class >>class
|
||||
dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
|
||||
init-literal-info
|
||||
] [
|
||||
dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
|
||||
null >>class
|
||||
|
|
@ -73,7 +101,7 @@ slots ;
|
|||
dup [ class>> ] [ interval>> ] bi interval>literal
|
||||
[ >>literal ] [ >>literal? ] bi*
|
||||
] if
|
||||
] if ;
|
||||
] if ; inline
|
||||
|
||||
: <class/interval-info> ( class interval -- info )
|
||||
<value-info>
|
||||
|
|
|
|||
|
|
@ -411,6 +411,14 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
|||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ integer array } ] [
|
||||
[
|
||||
[ 2drop T{ mixed-mutable-immutable f 3 { } } ]
|
||||
[ { array } declare mixed-mutable-immutable boa ] if
|
||||
[ x>> ] [ y>> ] bi
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
! Recursive propagation
|
||||
: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
|
||||
|
||||
|
|
@ -573,6 +581,14 @@ MIXIN: empty-mixin
|
|||
|
||||
[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[
|
||||
[ { float float } declare <complex> ]
|
||||
[ 2drop C{ 0.0 0.0 } ]
|
||||
if real-part
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
|
|
|||
|
|
@ -31,12 +31,6 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
: tuple-constructor? ( word -- ? )
|
||||
{ <tuple-boa> <complex> } memq? ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
#! Delegation.
|
||||
all-slots rest-slice
|
||||
[ read-only>> [ drop f ] unless ] 2map
|
||||
{ f f } prepend ;
|
||||
|
||||
: fold-<tuple-boa> ( values class -- info )
|
||||
[ , f , [ literal>> ] map % ] { } make >tuple
|
||||
<literal-info> ;
|
||||
|
|
|
|||
|
|
@ -514,8 +514,8 @@ IN: cpu.ppc.intrinsics
|
|||
! Alien intrinsics
|
||||
: %alien-accessor ( quot -- )
|
||||
"offset" operand dup %untag-fixnum
|
||||
"offset" operand dup "alien" operand ADD
|
||||
"value" operand "offset" operand 0 roll call ; inline
|
||||
"scratch" operand "offset" operand "alien" operand ADD
|
||||
"value" operand "scratch" operand 0 roll call ; inline
|
||||
|
||||
: alien-integer-get-template
|
||||
H{
|
||||
|
|
@ -539,6 +539,7 @@ IN: cpu.ppc.intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { "scratch" } }
|
||||
{ +clobber+ { "value" "offset" } }
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -44,29 +44,29 @@ M: pasteboard set-clipboard-contents
|
|||
dup install-window-delegate
|
||||
over -> release
|
||||
<handle>
|
||||
] keep set-world-handle ;
|
||||
] keep (>>handle) ;
|
||||
|
||||
M: cocoa-ui-backend set-title ( string world -- )
|
||||
world-handle window>> swap <NSString> -> setTitle: ;
|
||||
handle>> window>> swap <NSString> -> setTitle: ;
|
||||
|
||||
: enter-fullscreen ( world -- )
|
||||
world-handle view>>
|
||||
handle>> view>>
|
||||
NSScreen -> mainScreen
|
||||
f -> enterFullScreenMode:withOptions:
|
||||
drop ;
|
||||
|
||||
: exit-fullscreen ( world -- )
|
||||
world-handle view>> f -> exitFullScreenModeWithOptions: ;
|
||||
handle>> view>> f -> exitFullScreenModeWithOptions: ;
|
||||
|
||||
M: cocoa-ui-backend set-fullscreen* ( ? world -- )
|
||||
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
|
||||
|
||||
M: cocoa-ui-backend fullscreen* ( world -- ? )
|
||||
world-handle view>> -> isInFullScreenMode zero? not ;
|
||||
handle>> view>> -> isInFullScreenMode zero? not ;
|
||||
|
||||
: auto-position ( world -- )
|
||||
dup window-loc>> { 0 0 } = [
|
||||
world-handle window>> -> center
|
||||
handle>> window>> -> center
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
|
@ -74,20 +74,20 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
|
|||
M: cocoa-ui-backend (open-window) ( world -- )
|
||||
dup gadget-window
|
||||
dup auto-position
|
||||
world-handle window>> f -> makeKeyAndOrderFront: ;
|
||||
handle>> window>> f -> makeKeyAndOrderFront: ;
|
||||
|
||||
M: cocoa-ui-backend (close-window) ( handle -- )
|
||||
window>> -> release ;
|
||||
|
||||
M: cocoa-ui-backend close-window ( gadget -- )
|
||||
find-world [
|
||||
world-handle [
|
||||
handle>> [
|
||||
window>> f -> performClose:
|
||||
] when*
|
||||
] when* ;
|
||||
|
||||
M: cocoa-ui-backend raise-window* ( world -- )
|
||||
world-handle [
|
||||
handle>> [
|
||||
window>> dup f -> orderFront: -> makeKeyWindow
|
||||
NSApp 1 -> activateIgnoringOtherApps:
|
||||
] when* ;
|
||||
|
|
|
|||
|
|
@ -19,3 +19,11 @@ M: byte-array resize
|
|||
resize-byte-array ;
|
||||
|
||||
INSTANCE: byte-array sequence
|
||||
|
||||
: 1byte-array ( x -- array ) 1 <byte-array> [ set-first ] keep ; inline
|
||||
|
||||
: 2byte-array ( x y -- array ) B{ } 2sequence ; inline
|
||||
|
||||
: 3byte-array ( x y z -- array ) B{ } 3sequence ; inline
|
||||
|
||||
: 4byte-array ( w x y z -- array ) B{ } 4sequence ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,19 @@
|
|||
USING: math math.order kernel arrays byte-arrays sequences
|
||||
colors.hsv benchmark.mandel.params ;
|
||||
IN: benchmark.mandel.colors
|
||||
|
||||
: scale 255 * >fixnum ; inline
|
||||
|
||||
: scale-rgb ( r g b -- n ) [ scale ] tri@ 3byte-array ;
|
||||
|
||||
: sat 0.85 ; inline
|
||||
: val 0.85 ; inline
|
||||
|
||||
: <color-map> ( nb-cols -- map )
|
||||
dup [
|
||||
360 * swap 1+ / sat val
|
||||
3array hsv>rgb first3 scale-rgb
|
||||
] with map ;
|
||||
|
||||
: color-map ( -- map )
|
||||
nb-iter max-color min <color-map> ; foldable
|
||||
|
|
@ -1,69 +1,45 @@
|
|||
USING: arrays io kernel math math.order namespaces sequences
|
||||
byte-arrays byte-vectors math.functions math.parser io.files
|
||||
colors.hsv io.encodings.binary ;
|
||||
|
||||
USING: arrays io kernel math math.functions math.order
|
||||
math.parser sequences locals byte-arrays byte-vectors io.files
|
||||
io.encodings.binary benchmark.mandel.params
|
||||
benchmark.mandel.colors ;
|
||||
IN: benchmark.mandel
|
||||
|
||||
: max-color 360 ; inline
|
||||
: zoom-fact 0.8 ; inline
|
||||
: width 640 ; inline
|
||||
: height 480 ; inline
|
||||
: nb-iter 40 ; inline
|
||||
: center -0.65 ; inline
|
||||
|
||||
: scale 255 * >fixnum ; inline
|
||||
|
||||
: scale-rgb ( r g b -- n ) [ scale ] tri@ 3array ;
|
||||
|
||||
: sat 0.85 ; inline
|
||||
: val 0.85 ; inline
|
||||
|
||||
: <color-map> ( nb-cols -- map )
|
||||
dup [
|
||||
360 * swap 1+ / sat val
|
||||
3array hsv>rgb first3 scale-rgb
|
||||
] with map ;
|
||||
|
||||
: iter ( c z nb-iter -- x )
|
||||
over absq 4.0 >= over zero? or
|
||||
[ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline recursive
|
||||
|
||||
SYMBOL: cols
|
||||
dup 0 <= [ 2nip ] [
|
||||
over absq 4.0 >= [ 2nip ] [
|
||||
>r sq dupd + r> 1- iter
|
||||
] if
|
||||
] if ; inline recursive
|
||||
|
||||
: x-inc width 200000 zoom-fact * / ; inline
|
||||
: y-inc height 150000 zoom-fact * / ; inline
|
||||
|
||||
: c ( i j -- c )
|
||||
>r
|
||||
x-inc * center real-part x-inc width 2 / * - + >float
|
||||
r>
|
||||
y-inc * center imaginary-part y-inc height 2 / * - + >float
|
||||
[ x-inc * center real-part x-inc width 2 / * - + >float ]
|
||||
[ y-inc * center imaginary-part y-inc height 2 / * - + >float ] bi*
|
||||
rect> ; inline
|
||||
|
||||
: render ( -- )
|
||||
:: render ( accum -- )
|
||||
height [
|
||||
width swap [
|
||||
c 0 nb-iter iter dup zero? [
|
||||
drop "\0\0\0"
|
||||
] [
|
||||
cols get [ length mod ] keep nth
|
||||
] if %
|
||||
c C{ 0.0 0.0 } nb-iter iter dup zero?
|
||||
[ drop B{ 0 0 0 } ] [ color-map [ length mod ] keep nth ] if
|
||||
accum push-all
|
||||
] curry each
|
||||
] each ;
|
||||
] each ; inline
|
||||
|
||||
: ppm-header ( w h -- )
|
||||
"P6\n" % swap # " " % # "\n255\n" % ;
|
||||
:: ppm-header ( accum -- )
|
||||
"P6\n" accum push-all
|
||||
width number>string accum push-all
|
||||
" " accum push-all
|
||||
height number>string accum push-all
|
||||
"\n255\n" accum push-all ; inline
|
||||
|
||||
: buf-size ( -- n ) width height * 3 * 100 + ;
|
||||
: buf-size ( -- n ) width height * 3 * 100 + ; inline
|
||||
|
||||
: mandel ( -- data )
|
||||
[
|
||||
buf-size <byte-vector> building set
|
||||
width height ppm-header
|
||||
nb-iter max-color min <color-map> cols set
|
||||
render
|
||||
building get >byte-array
|
||||
] with-scope ;
|
||||
buf-size <byte-vector>
|
||||
[ ppm-header ] [ render ] [ B{ } like ] tri ;
|
||||
|
||||
: mandel-main ( -- )
|
||||
mandel "mandel.ppm" temp-file binary set-file-contents ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
IN: benchmark.mandel.params
|
||||
|
||||
: max-color 360 ; inline
|
||||
: zoom-fact 0.8 ; inline
|
||||
: width 640 ; inline
|
||||
: height 480 ; inline
|
||||
: nb-iter 40 ; inline
|
||||
: center -0.65 ; inline
|
||||
Loading…
Reference in New Issue