Cleaning up tuples

core/classes/tuple/tuple.factor

@@ -23,8 +23,15 @@ M: class tuple-layout "layout" word-prop ;
 
 M: tuple tuple-layout 1 slot ;
 
+M: tuple-layout tuple-layout ;
 : tuple-size tuple-layout layout-size ; inline
 
+: prepare-tuple>array ( tuple -- n tuple layout )
+    [ tuple-size ] [ ] [ tuple-layout ] tri ;
+
+: copy-tuple-slots ( n tuple first -- array )
+    [ array-nth ] curry map r> add* ;
+
 PRIVATE>
 
 : check-tuple ( class -- )
@@ -32,28 +39,29 @@ PRIVATE>
     [ drop ] [ no-tuple-class ] if ;
 
 : tuple>array ( tuple -- array )
-    dup tuple-layout
-    [ layout-size swap [ array-nth ] curry map ] keep
-    layout-class add* ;
+    prepare-tuple>array >r copy-tuple-slots r> layout-class add* ;
 
-: >tuple ( seq -- tuple )
-    dup first tuple-layout <tuple> [
-        >r 1 tail-slice dup length r>
-        [ tuple-size min ] keep
-        [ set-array-nth ] curry
-        2each
+: tuple-slots ( tuple -- array )
+    prepare-tuple>array drop copy-tuple-slots ;
+
+: slots>tuple ( tuple class -- array )
+    tuple-layout <tuple> [
+        [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
     ] keep ;
 
+: >tuple ( tuple -- array )
+    unclip slots>tuple ;
+
 : slot-names ( class -- seq )
-    "slots" word-prop [ name>> ] map ;
+    "slot-names" word-prop ;
 
 <PRIVATE
 
 : tuple= ( tuple1 tuple2 -- ? )
-    over tuple-layout over tuple-layout eq? [
-        dup tuple-size -rot
-        [ >r over r> array-nth >r array-nth r> = ] 2curry
-        all-integers?
+    2dup [ tuple-layout ] bi@ eq? [
+        [ drop tuple-size ]
+        [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
+        2bi all-integers?
     ] [
         2drop f
     ] if ;
@@ -92,18 +100,19 @@ PRIVATE>
     superclasses 1 head-slice*
     [ slot-names length ] map sum ;
 
-: generate-tuple-slots ( class slots -- slots )
+: generate-tuple-slots ( class slots -- slot-specs )
     over superclass-size 2 + simple-slots ;
 
-: define-tuple-slots ( class slots -- )
-    dupd generate-tuple-slots
+: define-tuple-slots ( class -- )
+    dup dup slot-names generate-tuple-slots
     [ "slots" set-word-prop ]
-    [ define-accessors ]
-    [ define-slots ] 2tri ;
+    [ define-accessors ] ! new
+    [ define-slots ] ! old
+    2tri ;
 
 : make-tuple-layout ( class -- layout )
     [ ]
-    [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
+    [ [ superclass-size ] [ slot-names length ] bi + ]
     [ superclasses dup length 1- ] tri
     <tuple-layout> ;
 
@@ -113,7 +122,7 @@ PRIVATE>
 : removed-slots ( class newslots -- seq )
     swap slot-names seq-diff ;
 
-: forget-slots ( class slots -- )
+: forget-removed-slots ( class slots -- )
     dupd removed-slots [
         [ reader-word forget-method ]
         [ writer-word forget-method ] 2bi
@@ -122,36 +131,48 @@ PRIVATE>
 : permutation ( seq1 seq2 -- permutation )
     swap [ index ] curry map ;
 
-: reshape-tuple ( oldtuple permutation -- newtuple )
-    >r tuple>array 2 cut r>
-    [ [ swap ?nth ] [ drop f ] if* ] with map
-    append >tuple ;
+: all-slot-names ( class -- slots )
+    superclasses [ slot-names ] map concat \ class add* ;
 
-: reshape-tuples ( class superclass newslots -- )
-    nip
-    >r dup slot-names r> permutation
-    [
-        >r "predicate" word-prop instances dup
-        r> [ reshape-tuple ] curry map
-        become
-    ] 2curry after-compilation ;
+: slot-permutation ( class superclass newslots -- n permutation )
+    [ all-slot-names ] [ all-slot-names ] [ ] tri* append
+    [ drop length ] [ permutation ] 2bi ;
+
+: permute-direct-slots ( oldslots permutation -- newslots )
+    [ [ swap ?nth ] [ drop f ] if* ] with map ;
+
+: permute-all-slots ( oldslots n permutation -- newslots )
+    [ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ;
+
+: change-tuple ( tuple quot -- newtuple )
+    >r tuple>array r> call >tuple ; inline
+
+: update-tuples ( predicate n permutation -- )
+    [ permute-all-slots ] 2curry [ change-tuple ] curry
+    >r "predicate" word-prop instances dup r> map
+    become ; inline
+
+: update-tuples-after ( class superclass newslots -- )
+    [ 2drop ] [ slot-permutation ] 3bi
+    [ update-tuples ] 3curry after-compilation ;
 
 : define-new-tuple-class ( class superclass slots -- )
     [ drop f tuple-class define-class ]
-    [ nip define-tuple-slots ] [
+    [ nip "slot-names" set-word-prop ] [
         2drop
         class-usages keys [ tuple-class? ] subset [
+            [ define-tuple-slots ]
             [ define-tuple-layout ]
             [ define-tuple-predicate ]
-            bi
+            tri
         ] each
     ] 3tri ;
 
 : redefine-tuple-class ( class superclass slots -- )
-    [ reshape-tuples ]
+    [ update-tuples-after ]
     [
         nip
-        [ forget-slots ]
+        [ forget-removed-slots ]
         [ drop changed-word ]
         [ drop redefined ]
         2tri
@@ -175,7 +196,7 @@ M: tuple-class define-tuple-class
     3drop ;
 
 : define-error-class ( class superclass slots -- )
-    pick >r define-tuple-class r>
+    [ define-tuple-class ] [ 2drop ] 3bi
     dup [ construct-boa throw ] curry define ;
 
 M: tuple clone
@@ -196,8 +217,6 @@ M: tuple hashcode*
         ] 2curry reduce
     ] recursive-hashcode ;
 
-: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
-
 ! Definition protocol
 M: tuple-class reset-class
     { "metaclass" "superclass" "slots" "layout" } reset-props ;

core/slots/slots.factor

@@ -23,9 +23,6 @@ C: <slot-spec> slot-spec
         [ drop ] [ 1array , \ declare , ] if
     ] [ ] make ;
 
-: slot-named ( name specs -- spec/f )
-    [ slot-spec-name = ] with find nip ;
-
 : create-accessor ( name effect -- word )
     >r "accessors" create dup r>
     "declared-effect" set-word-prop ;