Minor updates

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 float } { array object } ;
-HINTS: v/n { float-array object } { array object } ;
+HINTS: n*v { float float-array } { array object } ;
-HINTS: n/v { object float-array } { object array } ;
+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 } ;

basis/ui/gadgets/canvas/canvas.factor

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

basis/ui/gadgets/handler/handler.factor

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

basis/units/units.factor

@@ -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@ =

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
+USING: arrays accessors float-arrays io io.files
-math.functions math.vectors math.parser namespaces sequences
+io.encodings.binary kernel math math.functions math.vectors
-sequences.private words io.encodings.binary ;
+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
+    over dir>> over lambda>> v*n
-    swap hit-normal delta v*n v+
+    swap normal>> delta v*n v+
-    swap ray-orig v+ ; inline
+    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 =
+        [ sray-intersect lambda>> 1.0/0.0 = ] keep swap
-        [ r> neg ] [ r> drop 0.0 ] if
+        [ 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 ;

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 ;

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 -- )

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 ( -- )

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
+USING: accessors sequences kernel math io calendar grouping
-calendar.model arrays models models.filter namespaces ui.gadgets
+calendar.format calendar.model arrays models models.filter
-ui.gadgets.labels ui.gadgets.theme ui ;
+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 )
-    {
+    [ hour>> ] [ minute>> ] [ second>> >fixnum ] tri
-        timestamp-hour timestamp-minute timestamp-second
+    3array [ pad-00 ] map ":" join ;
-    } get-slots >fixnum 3array [ pad-00 ] map ":" join ;
 
 : <time-display> ( timestamp -- gadget )
     [ hh:mm:ss lcd ] <filter> <label-control>

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
+            { [ data>> ] [ ld>> ] [ cols>> ] [ element-type heap-size ] } cleave
-            heap-size * * memory>byte-array
+            * * memory>byte-array
-        ] [ { ld>> rows>> cols>> transpose>> } get-slots ] bi
+        ] [ { [ 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?
     {

extra/maze/maze.factor

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

extra/processing/gadget/gadget.factor

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

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 } ;