diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor index ea41dc5436..61ebe744f8 100755 --- a/basis/float-arrays/float-arrays.factor +++ b/basis/float-arrays/float-arrays.factor @@ -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 } ; diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor index cfc7c4cfd6..ba5aeaf95b 100644 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -7,9 +7,8 @@ IN: ui.gadgets.canvas TUPLE: canvas < gadget dlist ; -: ( -- 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 diff --git a/basis/ui/gadgets/handler/handler.factor b/basis/ui/gadgets/handler/handler.factor index bff03c7d9f..1ad5063013 100644 --- a/basis/ui/gadgets/handler/handler.factor +++ b/basis/ui/gadgets/handler/handler.factor @@ -7,5 +7,5 @@ TUPLE: handler < wrapper table ; : ( child -- handler ) handler new-wrapper ; -M: handler handle-gesture* ( gadget gesture delegate -- ? ) - table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file +M: handler handle-gesture ( gesture gadget -- ? ) + over table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file diff --git a/basis/units/units.factor b/basis/units/units.factor index 251a4e9b47..fb93691f0a 100755 --- a/basis/units/units.factor +++ b/basis/units/units.factor @@ -33,7 +33,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; \ [ >dimensioned< ] define-inverse : dimensions ( dimensioned -- top bot ) - { dimensioned-top dimensioned-bot } get-slots ; + [ top>> ] [ bot>> ] bi ; : check-dimensions ( d d -- ) [ dimensions 2array ] bi@ = diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 7d7ec244fb..d22f339ed4 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -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 -TUPLE: hit normal lambda ; +TUPLE: hit { normal float-array read-only } { lambda float read-only } ; C: 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-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 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 nip ] if-ray-sphere ; -TUPLE: group objs ; +TUPLE: group < sphere { objs array read-only } ; : ( 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> ; inline + swap [ { } make ] dip ; 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 r> initial-intersect ; inline + swap [ ray-o light vneg ] 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 , - [ >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 ] with map + [ v+ normalize F{ 0.0 0.0 -4.0 } swap ] 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 ; diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index 7b1fac8fcd..b990de03fc 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -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 ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 5c77568106..edcf0c7d26 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -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 -- ) diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index 15ef21d64e..e14a46a967 100755 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -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 ( -- ) diff --git a/extra/lcd/lcd.factor b/extra/lcd/lcd.factor index b0d5060b4a..d1646a4089 100755 --- a/extra/lcd/lcd.factor +++ b/extra/lcd/lcd.factor @@ -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 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 ; : ( timestamp -- gadget ) [ hh:mm:ss lcd ] diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor index c07dfca76d..c8e55c4ec0 100755 --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -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? { diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index 389dabc0f6..07f7b74265 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -49,10 +49,9 @@ SYMBOL: visited { 0 0 } dup vertex (draw-maze) glEnd ; -TUPLE: maze ; +TUPLE: maze < canvas ; -: ( -- gadget ) - { set-delegate } maze construct ; +: ( -- gadget ) maze new-canvas ; : n ( gadget -- n ) rect-dim first2 min line-width /i ; diff --git a/extra/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor index 4621bab855..c1a4c77703 100644 --- a/extra/processing/gadget/gadget.factor +++ b/extra/processing/gadget/gadget.factor @@ -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? ] diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index ff88abad61..4a36121046 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -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 } ;