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

Minor updates

db4
Slava Pestov 2008-08-27 16:24:04 -05:00
parent 4bc54497fa
commit 8346554b07
13 changed files with 63 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/float-arrays/float-arrays.factor
View File

@ -68,9 +68,10 @@ M: float-array >pprint-sequence ;
USING: hints math.vectors arrays ;
HINTS: vneg { float-array } { array } ;
HINTS: v*n { float-array object } { array object } ;
HINTS: v/n { float-array object } { array object } ;
HINTS: n/v { object float-array } { object array } ;
HINTS: v*n { float-array float } { array object } ;
HINTS: n*v { float float-array } { array object } ;
HINTS: v/n { float-array float } { array object } ;
HINTS: n/v { float float-array } { object array } ;
HINTS: v+ { float-array float-array } { array array } ;
HINTS: v- { float-array float-array } { array array } ;
HINTS: v* { float-array float-array } { array array } ;

5
basis/ui/gadgets/canvas/canvas.factor
View File

@ -7,9 +7,8 @@ IN: ui.gadgets.canvas
TUPLE: canvas < gadget dlist ;
: <canvas> ( -- canvas )
canvas new-gadget
black solid-interior ;
: new-canvas ( class -- canvas )
new-gadget black solid-interior ; inline
: delete-canvas-dlist ( canvas -- )
dup find-gl-context

4
basis/ui/gadgets/handler/handler.factor
View File

@ -7,5 +7,5 @@ TUPLE: handler < wrapper table ;
: <handler> ( child -- handler ) handler new-wrapper ;
M: handler handle-gesture* ( gadget gesture delegate -- ? )
table>> at dup [ call f ] [ 2drop t ] if ;
M: handler handle-gesture ( gesture gadget -- ? )
over table>> at dup [ call f ] [ 2drop t ] if ;

2
basis/units/units.factor
View File

@ -33,7 +33,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
\ <dimensioned> [ >dimensioned< ] define-inverse
: dimensions ( dimensioned -- top bot )
{ dimensioned-top dimensioned-bot } get-slots ;
[ top>> ] [ bot>> ] bi ;
: check-dimensions ( d d -- )
[ dimensions 2array ] bi@ =

63
extra/benchmark/raytracer/raytracer.factor
View File

@ -1,9 +1,9 @@
! Factor port of the raytracer benchmark from
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
USING: float-arrays compiler generic io io.files kernel math
math.functions math.vectors math.parser namespaces sequences
sequences.private words io.encodings.binary ;
USING: arrays accessors float-arrays io io.files
io.encodings.binary kernel math math.functions math.vectors
math.parser namespaces sequences sequences.private words ;
IN: benchmark.raytracer
! parameters
@ -23,32 +23,33 @@ IN: benchmark.raytracer
: delta 1.4901161193847656E-8 ; inline
TUPLE: ray orig dir ;
TUPLE: ray { orig float-array read-only } { dir float-array read-only } ;
C: <ray> ray
TUPLE: hit normal lambda ;
TUPLE: hit { normal float-array read-only } { lambda float read-only } ;
C: <hit> hit
GENERIC: intersect-scene ( hit ray scene -- hit )
TUPLE: sphere center radius ;
TUPLE: sphere { center float-array read-only } { radius float read-only } ;
C: <sphere> sphere
: sphere-v ( sphere ray -- v )
swap sphere-center swap ray-orig v- ; inline
swap center>> swap orig>> v- ; inline
: sphere-b ( ray v -- b ) swap ray-dir v. ; inline
: sphere-b ( ray v -- b ) swap dir>> v. ; inline
: sphere-disc ( sphere v b -- d )
sq swap norm-sq - swap sphere-radius sq + ; inline
sq swap norm-sq - swap radius>> sq + ; inline
: -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
: sphere-b/d ( b d -- t )
-+ dup 0.0 < [ 2drop 1.0/0.0 ] [ >r [ 0.0 > ] keep r> ? ] if ; inline
-+ dup 0.0 <
[ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
: ray-sphere ( sphere ray -- t )
2dup sphere-v tuck sphere-b [ sphere-disc ] keep
@ -56,29 +57,31 @@ C: <sphere> sphere
inline
: sphere-n ( ray sphere l -- n )
pick ray-dir n*v swap sphere-center v- swap ray-orig v+ ;
pick dir>> n*v swap center>> v- swap orig>> v+ ;
inline
: if-ray-sphere ( hit ray sphere quot -- hit )
#! quot: hit ray sphere l -- hit
>r pick hit-lambda >r 2dup swap ray-sphere dup r> >=
[ 3drop ] r> if ; inline
[
pick lambda>> [ 2dup swap ray-sphere dup ] dip >=
[ 3drop ]
] dip if ; inline
M: sphere intersect-scene ( hit ray sphere -- hit )
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
TUPLE: group objs ;
TUPLE: group < sphere { objs array read-only } ;
: <group> ( objs bound -- group )
{ set-group-objs set-delegate } group construct ;
[ center>> ] [ radius>> ] bi rot group boa ; inline
: make-group ( bound quot -- )
swap >r { } make r> <group> ; inline
swap [ { } make ] dip <group> ; inline
M: group intersect-scene ( hit ray group -- hit )
[
drop
group-objs [ >r tuck r> intersect-scene swap ] each
objs>> [ [ tuck ] dip intersect-scene swap ] each
drop
] if-ray-sphere ;
@ -88,30 +91,30 @@ M: group intersect-scene ( hit ray group -- hit )
initial-hit -rot intersect-scene ; inline
: ray-o ( ray hit -- o )
over ray-dir over hit-lambda v*n
swap hit-normal delta v*n v+
swap ray-orig v+ ; inline
over dir>> over lambda>> v*n
swap normal>> delta v*n v+
swap orig>> v+ ; inline
: sray-intersect ( ray scene hit -- ray )
swap >r ray-o light vneg <ray> r> initial-intersect ; inline
swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
: ray-g ( hit -- g ) hit-normal light v. ; inline
: ray-g ( hit -- g ) normal>> light v. ; inline
: cast-ray ( ray scene -- g )
2dup initial-intersect dup hit-lambda 1.0/0.0 = [
2dup initial-intersect dup lambda>> 1.0/0.0 = [
3drop 0.0
] [
dup ray-g >r sray-intersect hit-lambda 1.0/0.0 =
[ r> neg ] [ r> drop 0.0 ] if
[ sray-intersect lambda>> 1.0/0.0 = ] keep swap
[ ray-g neg ] [ drop 0.0 ] if
] if ; inline
: create-center ( c r d -- c2 )
>r 3.0 12.0 sqrt / * r> n*v v+ ; inline
[ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
DEFER: create ( level c r -- scene )
: create-step ( level c r d -- scene )
over >r create-center r> 2.0 / >r >r 1 - r> r> create ;
over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
: create-offsets ( quot -- )
{
@ -126,7 +129,7 @@ DEFER: create ( level c r -- scene )
: create-group ( level c r -- scene )
2dup create-bound [
2dup <sphere> ,
[ >r 3dup r> create-step , ] create-offsets 3drop
[ [ 3dup ] dip create-step , ] create-offsets 3drop
] make-group ;
: create ( level c r -- scene )
@ -140,7 +143,7 @@ DEFER: create ( level c r -- scene )
: ray-grid ( point ss-grid -- ray-grid )
[
[ v+ normalize { 0.0 0.0 -4.0 } swap <ray> ] with map
[ v+ normalize F{ 0.0 0.0 -4.0 } swap <ray> ] with map
] with map ;
: ray-pixel ( scene point -- n )
@ -164,7 +167,7 @@ DEFER: create ( level c r -- scene )
pixel-grid [ [ ray-pixel ] with map ] with map ;
: run ( -- string )
levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [
levels F{ 0.0 -1.0 0.0 } 1.0 create ray-trace [
size size pgm-header
[ [ oversampling sq / pgm-pixel ] each ] each
] B{ } make ;

2
extra/gesture-logger/gesture-logger.factor
View File

@ -13,7 +13,7 @@ TUPLE: gesture-logger < gadget stream ;
{ 100 100 } >>dim
black solid-interior ;
M: gesture-logger handle-gesture*
M: gesture-logger handle-gesture
over T{ button-down } = [ dup request-focus ] when
stream>> [ . ] with-output-stream*
t ;

11
extra/inverse/inverse.factor
View File

@ -226,17 +226,6 @@ DEFER: _
\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
: writer>reader ( word -- word' )
[ "writing" word-prop "slots" word-prop ] keep
[ swap slot-spec-writer = ] curry find nip slot-spec-reader ;
: construct-inverse ( class setters -- quot )
>r deconstruct-pred r>
[ writer>reader ] map [ get-slots ] curry
compose ;
\ construct 2 [ >r ?wrapped r> construct-inverse ] define-pop-inverse
! More useful inverse-based combinators
: recover-fail ( try fail -- )

2
extra/key-caps/key-caps.factor
View File

@ -168,7 +168,7 @@ M: key-caps-gadget graft*
M: key-caps-gadget ungraft*
alarm>> [ cancel-alarm ] when* ;
M: key-caps-gadget handle-gesture*
M: key-caps-gadget handle-gesture
drop [ key-down? ] [ key-up? ] bi or not ;
: key-caps ( -- )

13
extra/lcd/lcd.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel math io calendar calendar.format
calendar.model arrays models models.filter namespaces ui.gadgets
ui.gadgets.labels ui.gadgets.theme ui ;
USING: accessors sequences kernel math io calendar grouping
calendar.format calendar.model arrays models models.filter
namespaces ui.gadgets ui.gadgets.labels ui.gadgets.theme ui ;
IN: lcd
: lcd-digit ( row digit -- str )
@ -11,7 +11,7 @@ IN: lcd
" | | | _| _| |_| |_ |_ | |_| |_| * "
" |_| | |_ _| | _| |_| | |_| | * "
" "
} nth >r 4 * dup 4 + r> subseq ;
} nth 4 <groups> nth ;
: lcd-row ( num row -- string )
[ swap lcd-digit ] curry { } map-as concat ;
@ -20,9 +20,8 @@ IN: lcd
4 [ lcd-row ] with map "\n" join ;
: hh:mm:ss ( timestamp -- string )
{
timestamp-hour timestamp-minute timestamp-second
} get-slots >fixnum 3array [ pad-00 ] map ":" join ;
[ hour>> ] [ minute>> ] [ second>> >fixnum ] tri
3array [ pad-00 ] map ":" join ;
: <time-display> ( timestamp -- gadget )
[ hh:mm:ss lcd ] <filter> <label-control>

8
extra/math/blas/matrices/matrices.factor
View File

@ -194,9 +194,9 @@ METHOD: n*M.M+n*M-in-place { number double-complex-blas-matrix double-complex-bl
syntax:M: blas-matrix-base clone
[
[
{ data>> ld>> cols>> element-type } get-slots
heap-size * * memory>byte-array
] [ { ld>> rows>> cols>> transpose>> } get-slots ] bi
{ [ data>> ] [ ld>> ] [ cols>> ] [ element-type heap-size ] } cleave
* * memory>byte-array
] [ { [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> ] } cleave ] bi
] keep (blas-matrix-like) ;
! XXX try rounding stride to next 128 bit bound for better vectorizin'
@ -296,7 +296,7 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
recip swap n*M ; inline
: Mtranspose ( matrix -- matrix^T )
[ { data>> ld>> rows>> cols>> transpose>> } get-slots not ] keep (blas-matrix-like) ;
[ { [ data>> ] [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> not ] } cleave ] keep (blas-matrix-like) ;
syntax:M: blas-matrix-base equal?
{

5
extra/maze/maze.factor
View File

@ -49,10 +49,9 @@ SYMBOL: visited
{ 0 0 } dup vertex (draw-maze)
glEnd ;
TUPLE: maze ;
TUPLE: maze < canvas ;
: <maze> ( -- gadget )
<canvas> { set-delegate } maze construct ;
: <maze> ( -- gadget ) maze new-canvas ;
: n ( gadget -- n ) rect-dim first2 min line-width /i ;

4
extra/processing/gadget/gadget.factor
View File

@ -26,8 +26,8 @@ SYMBOL: key-value
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: processing-gadget handle-gesture* ( gadget gesture delegate -- ? )
rot drop swap ! delegate gesture
M: processing-gadget handle-gesture ( gesture gadget -- ? )
swap
{
{
[ dup key-down? ]

8
extra/reports/noise/noise.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs math kernel shuffle generalizations
words quotations arrays combinators sequences math.vectors
io.styles prettyprint vocabs sorting io generic locals.private
@ -92,11 +94,11 @@ M: word noise badness 1 2array ;
M: wrapper noise wrapped>> noise ;
M: let noise let-body noise ;
M: let noise body>> noise ;
M: wlet noise wlet-body noise ;
M: wlet noise body>> noise ;
M: lambda noise lambda-body noise ;
M: lambda noise body>> noise ;
M: object noise drop { 0 0 } ;