<string>Factor</string>
<key>CFBundlePackageType</key>
<string>APPL</string>
+ <key>CFBundleVersion</key>
+ <string>0.93</string>
<key>NSHumanReadableCopyright</key>
- <string>Copyright © 2003-2009, Slava Pestov and friends</string>
+ <string>Copyright © 2003-2010 Factor developers</string>
<key>NSServices</key>
<array>
<dict>
AR = ar
LD = ld
- VERSION = 0.92
+ VERSION = 0.93
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
[ { vector } declare length>> ]
count-unboxed-allocations
] unit-test
+
+! Bug found while tweaking benchmark.raytracer-simd
+
+TUPLE: point-2d { x read-only } { y read-only } ;
+TUPLE: point-3d < point-2d { z read-only } ;
+
+[ 0 ] [
+ [ { point-2d } declare dup point-3d? [ z>> ] [ x>> ] if ]
+ count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [ point-2d boa dup point-3d? [ z>> ] [ x>> ] if ]
+ count-unboxed-allocations
+] unit-test
: record-tuple-allocation ( #call -- )
dup immutable-tuple-boa?
- [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ]
+ [ [ in-d>> but-last { } like ] [ out-d>> first ] bi record-allocation ]
[ record-unknown-allocation ]
if ;
: slot-offset ( #call -- n/f )
- dup in-d>>
- [ second node-value-info literal>> ]
- [ first node-value-info class>> ] 2bi
- 2dup [ fixnum? ] [ tuple class<= ] bi* and [
- over 2 >= [ drop 2 - ] [ 2drop f ] if
+ dup in-d>> second node-value-info literal>> dup [ 2 - ] when ;
+
+: valid-slot-offset? ( slot# in -- ? )
+ over [
+ allocation dup [
+ dup array? [ bounds-check? ] [ 2drop f ] if
+ ] [ 2drop t ] if
] [ 2drop f ] if ;
+: unknown-slot-call ( out slot# in -- )
+ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ;
+
: record-slot-call ( #call -- )
- [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
+ [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
+ 2dup valid-slot-offset?
[ [ record-slot-access ] [ copy-slot-value ] 3bi ]
- [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
+ [ unknown-slot-call ]
if ;
M: #call escape-analysis*
-bitmap graphics
+graphics
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel locals words summary slots quotations
-sequences assocs math arrays stack-checker effects
-continuations debugger classes.tuple namespaces make vectors
-bit-arrays byte-arrays strings sbufs math.functions macros
-sequences.private combinators mirrors splitting combinators.smart
+sequences assocs math arrays stack-checker effects continuations
+classes.tuple namespaces make vectors bit-arrays byte-arrays
+strings sbufs math.functions macros sequences.private
+combinators mirrors splitting combinators.smart
combinators.short-circuit fry words.symbol generalizations
classes ;
IN: inverse
+++ /dev/null
-USING: kernel arrays math.vectors sequences math ;
-
-IN: math.points
-
-<PRIVATE
-
-: X ( x -- point ) 0 0 3array ;
-: Y ( y -- point ) 0 swap 0 3array ;
-: Z ( z -- point ) 0 0 rot 3array ;
-
-PRIVATE>
-
-: v+x ( seq x -- seq ) X v+ ;
-: v-x ( seq x -- seq ) X v- ;
-
-: v+y ( seq y -- seq ) Y v+ ;
-: v-y ( seq y -- seq ) Y v- ;
-
-: v+z ( seq z -- seq ) Z v+ ;
-: v-z ( seq z -- seq ) Z v- ;
-
-: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
-: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
-: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
-: midpoint ( point point -- point ) v+ 2 v/n ;
-: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
\ No newline at end of file
$nl
"SIMD support in the processor takes the form of instruction sets which operate on vector registers. By operating on multiple scalar values at the same time, code which operates on points, colors, and other vector data can be sped up."
$nl
-"In Factor, SIMD support is exposed in the form of special-purpose SIMD " { $link "sequence-protocol" } " implementations. These are fixed-length, homogeneous sequences. They are referred to as vectors, but should not be confused with Factor's " { $link "vectors" } ", which can hold any type of object and can be resized.)."
+"In Factor, SIMD support is exposed in the form of special-purpose SIMD " { $link "sequence-protocol" } " implementations. These are fixed-length, homogeneous sequences. They are referred to as vectors, but should not be confused with Factor's " { $link "vectors" } ", which can hold any type of object and can be resized."
$nl
"The words in the " { $vocab-link "math.vectors" } " vocabulary, which can be used with any sequence of numbers, are special-cased by the compiler. If the compiler can prove that only SIMD vectors are used, it expands " { $link "math-vectors" } " into " { $link "math.vectors.simd.intrinsics" } ". While in the general case, SIMD intrinsics operate on heap-allocated SIMD vectors, that too can be optimized since in many cases the compiler unbox SIMD vectors, storing them directly in registers."
$nl
ARTICLE: "math.vectors.simd.types" "SIMD vector types"
"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension."
$nl
-"The following vector types are available:"
+"The following 128-bit vector types are defined in the " { $vocab-link "math.vectors.simd" } " vocabulary:"
{ $code
"char-16"
"uchar-16"
"ulonglong-2"
"float-4"
"double-2"
+}
+"Double-width 256-bit vector types are defined in the " { $vocab-link "math.vectors.simd.cords" } " vocabulary:"
+{ $code
+ "char-32"
+ "uchar-32"
+ "short-16"
+ "ushort-16"
+ "int-8"
+ "uint-8"
+ "longlong-4"
+ "ulonglong-4"
+ "float-8"
+ "double-4"
} ;
ARTICLE: "math.vectors.simd.words" "SIMD vector words"
"""USE: compiler.tree.debugger
M\\ actor advance test-mr mr.""" }
-"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ;
+"Example of a high-performance algorithms that use SIMD primitives can be found in the following vocabularies:"
+{ $list
+ { $vocab-link "benchmark.nbody-simd" }
+ { $vocab-link "benchmark.raytracer-simd" }
+ { $vocab-link "random.sfmt" }
+} ;
ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
"The words in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary are used to implement SIMD support. These words have three disadvantages compared to the higher-level " { $link "math-vectors" } " words:"
} ;
ARTICLE: "inference-errors" "Stack checker errors"
-"These " { $link "inference" } " failure conditions are reported in one of two ways:"
+"Stack effect checking failure conditions are reported in one of two ways:"
{ $list
- { { $link "tools.inference" } " throws them as errors" }
- { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } }
+ { { $link "tools.inference" } " report them when fed quotations interactively" }
+ { "The " { $link "compiler" } " reports them while compiling words, via the " { $link "tools.errors" } " mechanism" }
}
"Errors thrown when insufficient information is available to calculate the stack effect of a call to a combinator or macro (see " { $link "inference-combinators" } "):"
{ $subsections
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
: word-timing. ( -- )
word-timing get
- >alist [ 1000000 /f ] assoc-map sort-values
+ >alist [ 1,000,000,000 /f ] assoc-map sort-values
simple-table. ;
} ;
ARTICLE: "deploy-resources" "Deployed resource files"
-"To include additional files in your deployed application, specify their names in a vocabulary's " { $snippet "resources.txt" } " file. The " { $snippet "resources.txt" } " file contains one glob pattern per line. These patterns are expanded relative to the vocabulary directory; files outside of the vocabulary directory cannot be referenced. If a file inside the vocabulary directory matches any of these patterns, it will be included in deployed applications that reference the vocabulary. If a subdirectory matches, its contents will be included recursively." ;
+"To include additional files in your deployed application, specify their names in a vocabulary's " { $snippet "resources.txt" } " file. The " { $snippet "resources.txt" } " file contains one glob pattern per line. These patterns are expanded relative to the vocabulary directory; files outside of the vocabulary directory cannot be referenced. If a file inside the vocabulary directory matches any of these patterns, it will be included in deployed applications that reference the vocabulary. If a subdirectory matches, its contents will be included recursively."
+$nl
+"If the deployed vocabulary includes an icon file for the current platform (" { $snippet "icon.ico" } " on Windows, or " { $snippet "icon.icns" } " on MacOS X), it will be embedded in the deployed application as its GUI icon." ;
ARTICLE: "tools.deploy.usage" "Deploy tool usage"
"Once the necessary deployment flags have been set, the application can be deployed:"
\r
[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test\r
\r
+[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test\r
+\r
[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
+[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test\r
+\r
os macosx? [\r
[ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
] when\r
--- /dev/null
+USING: accessors alien alien.c-types arrays classes.struct combinators\r
+io.backend kernel locals math sequences specialized-arrays\r
+tools.deploy.windows windows.kernel32 windows.types ;\r
+IN: tools.deploy.windows.ico\r
+\r
+<PRIVATE\r
+\r
+STRUCT: ico-header\r
+ { Reserved WORD }\r
+ { Type WORD }\r
+ { ImageCount WORD } ;\r
+\r
+STRUCT: ico-directory-entry\r
+ { Width BYTE }\r
+ { Height BYTE }\r
+ { Colors BYTE }\r
+ { Reserved BYTE }\r
+ { Planes WORD }\r
+ { BitsPerPixel WORD }\r
+ { ImageSize DWORD }\r
+ { ImageOffset DWORD } ;\r
+SPECIALIZED-ARRAY: ico-directory-entry\r
+\r
+STRUCT: group-directory-entry\r
+ { Width BYTE }\r
+ { Height BYTE }\r
+ { Colors BYTE }\r
+ { Reserved BYTE }\r
+ { Planes WORD }\r
+ { BitsPerPixel WORD }\r
+ { ImageSize DWORD }\r
+ { ImageResourceID WORD } ;\r
+\r
+: ico>group-directory-entry ( ico i -- group )\r
+ [ {\r
+ [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]\r
+ [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]\r
+ } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline\r
+\r
+: ico-icon ( directory-entry bytes -- subbytes )\r
+ [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline\r
+\r
+:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )\r
+ bytes ico-header memory>struct :> header\r
+\r
+ ico-header heap-size bytes <displaced-alien> \r
+ header ImageCount>> <direct-ico-directory-entry-array> :> directory\r
+\r
+ directory dup length iota [ ico>group-directory-entry ] { } 2map-as\r
+ :> group-directory\r
+ directory [ bytes ico-icon ] { } map-as :> icon-bytes\r
+\r
+ header clone >c-ptr group-directory concat append\r
+ icon-bytes ; inline\r
+\r
+PRIVATE>\r
+\r
+:: embed-icon-resource ( exe ico-bytes id -- )\r
+ exe normalize-path 1 BeginUpdateResource :> hUpdate\r
+ hUpdate [\r
+ ico-bytes ico-group-and-icons :> ( group icons )\r
+ hUpdate RT_GROUP_ICON id 0 group dup byte-length\r
+ UpdateResource drop\r
+\r
+ icons [| icon i |\r
+ hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length\r
+ UpdateResource drop\r
+ ] each-index\r
+\r
+ hUpdate 0 EndUpdateResource drop\r
+ ] when ;\r
+\r
--- /dev/null
+unportable
sequences locals system splitting tools.deploy.backend
tools.deploy.config tools.deploy.config.editor assocs hashtables
prettyprint combinators windows.kernel32 windows.shell32 windows.user32
-alien.c-types vocabs.metadata vocabs.loader ;
+alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico ;
IN: tools.deploy.windows
CONSTANT: app-icon-resource-id "APPICON"
dup copy-dll
deploy-ui? get ".exe" ".com" ? copy-vm ;
-:: (embed-ico) ( vm ico-bytes -- )
- vm 0 BeginUpdateResource :> hUpdate
- hUpdate [
- hUpdate RT_ICON app-icon-resource-id 0 ico-bytes dup byte-length
- UpdateResource drop
- hUpdate 0 EndUpdateResource drop
- ] when ;
-
: embed-ico ( vm vocab -- )
dup vocab-windows-icon-path vocab-append-path dup exists?
- [ binary file-contents (embed-ico) ]
+ [ binary file-contents app-icon-resource-id embed-icon-resource ]
[ 2drop ] if ;
M: winnt deploy*
}
{ $description "Outputs a sequence containing the individual resource files and directories that match the patterns specified in " { $snippet "vocab" } "'s " { $snippet "resources.txt" } " file. Any matching directories will also have their contents recursively included in the output. The paths in the output will be relative to " { $snippet "vocab" } "'s directory." } ;
-ARTICLE: "vocabs.metadata.resources" "vocabs.metadata.resources"
+ARTICLE: "vocabs.metadata.resources" "Vocabulary resource metadata"
"The " { $vocab-link "vocabs.metadata.resources" } " vocabulary contains words to retrieve the full list of files that match the patterns specified in a vocabulary's " { $snippet "resources.txt" } " file."
{ $subsections
vocab-resource-files
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences
-sequences.private namespaces math quotations assocs.private ;
+sequences.private namespaces math quotations assocs.private
+sets ;
IN: assocs
ARTICLE: "alists" "Association lists"
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
+$nl
+"Set-theoretic operations:"
{ $subsections
assoc-subset?
assoc-intersect
substitute
extract-keys
}
+"Adding elements to sets:"
+{ $subsections
+ conjoin
+ conjoin-at
+}
"Destructive operations:"
{ $subsections
assoc-union!
{ $subsections "conditionals-boolean-equivalence" }
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
-ARTICLE: "dataflow-combinators" "Data flow combinators"
-"Data flow combinators express common dataflow patterns such as performing a operation while preserving its inputs, applying multiple operations to a single value, applying a set of operations to a set of values, or applying a single operation to multiple values."
+ARTICLE: "dataflow-combinators" "Dataflow combinators"
+"Dataflow combinators express common dataflow patterns such as performing a operation while preserving its inputs, applying multiple operations to a single value, applying a set of operations to a set of values, or applying a single operation to multiple values."
{ $subsections
"dip-keep-combinators"
"cleave-combinators"
"spread-combinators"
"apply-combinators"
}
-"More intricate data flow can be constructed by composing " { $link "curried-dataflow" } "." ;
+"More intricate dataflow can be constructed by composing " { $link "curried-dataflow" } "." ;
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
ARTICLE: "sequences-integers" "Counted loops"
"A virtual sequence is defined for iterating over integers from zero."
{ $subsection iota }
-"For example, calling " { $link iota } " on the integer 3 produces a sequence containing the elements 0, 1, and 2. This is very useful for performing counted loops."
-$nl
-"This means the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
+"For example, calling " { $link iota } " on the integer 3 produces a sequence containing the elements 0, 1, and 2. This is very useful for performing counted loops using words such as " { $link each } ":"
{ $example "3 iota [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
"Adding elements to sets:"
{ $subsections
adjoin
- conjoin
- conjoin-at
}
{ $see-also member? member-eq? any? all? "assocs-sets" } ;
{ { $snippet "foo/bar/summary.txt" } " - a one-line description." }
{ { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can reuse." }
}
+"An icon file representing the vocabulary can also be provided. A file named " { $snippet "icon.ico" } " will be used as the application icon when the application is deployed on Windows. A file named " { $snippet "icon.icns" } " will be used when the application is deployed on MacOS X."
+$nl
"The " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " words load vocabularies which have not been loaded yet, as needed."
$nl
"Vocabularies can also be loaded at run time, without altering the vocabulary search path. This is done by calling a word which loads a vocabulary if it is not in the image, doing nothing if it is:"
-comments
-annotation
+tools
! Factor port of the raytracer benchmark from
-! http://www.ffconsultancy.com/free/ray_tracer/languages.html
+! http://www.ffconsultancy.com/languages/ray_tracer/index.html
USING: arrays accessors io io.files io.files.temp
io.encodings.binary kernel math math.constants math.functions
-math.vectors math.vectors.simd math.vectors.simd.cords math.parser
-make sequences sequences.private words hints classes.struct ;
-QUALIFIED-WITH: alien.c-types c
+math.vectors math.vectors.simd math.vectors.simd.cords
+math.parser make sequences words combinators ;
IN: benchmark.raytracer-simd
+<< SYNTAX: no-compile word t "no-compile" set-word-prop ; >>
+
! parameters
! Normalized { -1 -3 2 }.
CONSTANT: size 200
-: delta ( -- n ) epsilon sqrt ; inline
+: delta ( -- n ) epsilon sqrt ; inline no-compile
TUPLE: ray { orig double-4 read-only } { dir double-4 read-only } ;
C: <hit> hit
-GENERIC: intersect-scene ( hit ray scene -- hit )
-
TUPLE: sphere { center double-4 read-only } { radius float read-only } ;
C: <sphere> sphere
-: sphere-v ( sphere ray -- v )
- [ center>> ] [ orig>> ] bi* v- ; inline
+: sphere-v ( sphere ray -- v ) [ center>> ] [ orig>> ] bi* v- ; inline no-compile
-: sphere-b ( v ray -- b )
- dir>> v. ; inline
+: sphere-b ( v ray -- b ) dir>> v. ; inline no-compile
-: sphere-d ( sphere b v -- d )
- [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
+: sphere-d ( sphere b v -- d ) [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline no-compile
-: -+ ( x y -- x-y x+y )
- [ - ] [ + ] 2bi ; inline
+: -+ ( x y -- x-y x+y ) [ - ] [ + ] 2bi ; inline no-compile
: sphere-t ( b d -- t )
-+ dup 0.0 <
- [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
+ [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline no-compile
: sphere-b&v ( sphere ray -- b v )
[ sphere-v ] [ nip ] 2bi
- [ sphere-b ] [ drop ] 2bi ; inline
+ [ sphere-b ] [ drop ] 2bi ; inline no-compile
: ray-sphere ( sphere ray -- t )
[ drop ] [ sphere-b&v ] 2bi
[ drop ] [ sphere-d ] 3bi
- dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
+ dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline no-compile
-: if-ray-sphere ( hit ray sphere quot -- hit )
- #! quot: hit ray sphere l -- hit
+: if-ray-sphere ( hit ray sphere quot: ( hit ray sphere l -- hit ) -- hit )
[
[ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
[ drop ] [ < ] 2bi
- ] dip [ 3drop ] if ; inline
+ ] dip [ 3drop ] if ; inline no-compile
: sphere-n ( ray sphere l -- n )
[ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
- swap [ v*n ] dip v- v+ ; inline
-
-M: sphere intersect-scene ( hit ray sphere -- hit )
- [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
-
-HINTS: M\ sphere intersect-scene { hit ray sphere } ;
+ swap [ v*n ] dip v- v+ ; inline no-compile
TUPLE: group < sphere { objs array read-only } ;
: <group> ( objs bound -- group )
- [ center>> ] [ radius>> ] bi rot group boa ; inline
+ swap [ [ center>> ] [ radius>> ] bi ] dip group boa ; inline no-compile
: make-group ( bound quot -- )
- swap [ { } make ] dip <group> ; inline
+ swap [ { } make ] dip <group> ; inline no-compile
-M: group intersect-scene ( hit ray group -- hit )
- [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
-
-HINTS: M\ group intersect-scene { hit ray group } ;
+: intersect-scene ( hit ray scene -- hit )
+ {
+ { [ dup group? ] [ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ] }
+ { [ dup sphere? ] [ [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ] }
+ } cond ; inline recursive no-compile
CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. }
: initial-intersect ( ray scene -- hit )
- [ initial-hit ] 2dip intersect-scene ; inline
+ [ initial-hit ] 2dip intersect-scene ; inline no-compile
: ray-o ( ray hit -- o )
[ [ orig>> ] [ normal>> delta v*n ] bi* ]
[ [ dir>> ] [ lambda>> ] bi* v*n ]
- 2bi v+ v+ ; inline
+ 2bi v+ v+ ; inline no-compile
: sray-intersect ( ray scene hit -- ray )
- swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
+ swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline no-compile
-: ray-g ( hit -- g ) normal>> light v. ; inline
+: ray-g ( hit -- g ) normal>> light v. ; inline no-compile
: cast-ray ( ray scene -- g )
2dup initial-intersect dup lambda>> 1/0. = [
] [
[ sray-intersect lambda>> 1/0. = ] keep swap
[ ray-g neg ] [ drop 0.0 ] if
- ] if ; inline
+ ] if ; inline no-compile
: create-center ( c r d -- c2 )
- [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
+ [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline no-compile
DEFER: create ( level c r -- scene )
: create-step ( level c r d -- scene )
over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
-: create-offsets ( quot -- )
+CONSTANT: create-offsets
{
double-4{ -1.0 1.0 -1.0 0.0 }
double-4{ 1.0 1.0 -1.0 0.0 }
double-4{ -1.0 1.0 1.0 0.0 }
double-4{ 1.0 1.0 1.0 0.0 }
- } swap each ; inline
+ }
: create-bound ( c r -- sphere ) 3.0 * <sphere> ;
: create-group ( level c r -- scene )
2dup create-bound [
2dup <sphere> ,
- [ [ 3dup ] dip create-step , ] create-offsets 3drop
+ create-offsets [ create-step , ] with with with each
] make-group ;
: create ( level c r -- scene )
pick 1 = [ <sphere> nip ] [ create-group ] if ;
: ss-point ( dx dy -- point )
- [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
-
-: ss-grid ( -- ss-grid )
- oversampling iota [ oversampling iota [ ss-point ] with map ] map ;
-
-: ray-grid ( point ss-grid -- ray-grid )
- [
- [ v+ normalize double-4{ 0.0 0.0 -4.0 0.0 } swap <ray> ] with map
- ] with map ;
-
-: ray-pixel ( scene point -- n )
- ss-grid ray-grid [ 0.0 ] 2dip
- [ [ swap cast-ray + ] with each ] with each ;
-
-: pixel-grid ( -- grid )
- size iota reverse [
+ [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ; inline no-compile
+
+: ray-pixel ( scene point -- ray-grid )
+ [ 0.0 ] 2dip
+ oversampling iota [
+ oversampling iota [
+ ss-point v+ normalize
+ double-4{ 0.0 0.0 -4.0 0.0 } swap <ray>
+ swap cast-ray +
+ ] with with with each
+ ] with with each ; inline no-compile
+
+: ray-trace ( scene -- grid )
+ size iota <reversed> [
size iota [
[ size 0.5 * - ] bi@ swap size
- 0.0 double-4-boa
- ] with map
- ] map ;
+ 0.0 double-4-boa ray-pixel
+ ] with with map
+ ] with map ;
: pgm-header ( w h -- )
"P5\n" % swap # " " % # "\n255\n" % ;
: pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
-: ray-trace ( scene -- pixels )
- pixel-grid [ [ ray-pixel ] with map ] with map ;
-
: run ( -- string )
levels double-4{ 0.0 -1.0 0.0 0.0 } 1.0 create ray-trace [
size size pgm-header
--- /dev/null
+USING: kernel arrays math.vectors sequences math ;
+
+IN: math.points
+
+<PRIVATE
+
+: X ( x -- point ) 0 0 3array ;
+: Y ( y -- point ) 0 swap 0 3array ;
+: Z ( z -- point ) 0 0 rot 3array ;
+
+PRIVATE>
+
+: v+x ( seq x -- seq ) X v+ ;
+: v-x ( seq x -- seq ) X v- ;
+
+: v+y ( seq y -- seq ) Y v+ ;
+: v-y ( seq y -- seq ) Y v- ;
+
+: v+z ( seq z -- seq ) Z v+ ;
+: v-z ( seq z -- seq ) Z v- ;
+
+: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
+: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
+: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
+: midpoint ( point point -- point ) v+ 2 v/n ;
+: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
\ No newline at end of file
tools
applications
demos
-networking
+network
<login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
<pastebin> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
- <mason-app> <login-config> "builds.factorcode.org" add-responder
+ <mason-app> <login-config> test-db <alloy> "builds.factorcode.org" add-responder
home "docs" append-path <help-webapp> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
main-responder set-global ;
projects / factor.git / commitdiff