Remove more redundant branches from tuple type predicates and generic words with methods on tuple classes

core/classes/tuple/tuple.factor

@@ -90,20 +90,29 @@ ERROR: bad-superclass class ;
         2drop f
     ] if ; inline
 
+: tuple-instance-1? ( object class -- ? )
+    swap dup tuple? [
+        layout-of 7 slot eq?
+    ] [ 2drop f ] if ; inline
+
 : tuple-instance? ( object class offset -- ? )
-    #! 4 slot == superclasses>>
     rot dup tuple? [
         layout-of
         2dup 1 slot fixnum<=
         [ swap slot eq? ] [ 3drop f ] if
     ] [ 3drop f ] if ; inline
 
-: layout-class-offset ( class -- n )
-    tuple-layout third 2 * 5 + ;
+: layout-class-offset ( echelon -- n )
+    2 * 5 + ;
+
+: echelon-of ( class -- n )
+    tuple-layout third ;
 
 : define-tuple-predicate ( class -- )
-    dup dup layout-class-offset
-    [ tuple-instance? ] 2curry define-predicate ;
+    dup dup echelon-of {
+        { 1 [ [ tuple-instance-1? ] curry ] }
+        [ layout-class-offset [ tuple-instance? ] 2curry ]
+    } case define-predicate ;
 
 : class-size ( class -- n )
     superclasses [ "slots" word-prop length ] sigma ;
@@ -292,7 +301,7 @@ M: tuple-class reset-class
 M: tuple-class rank-class drop 0 ;
 
 M: tuple-class instance?
-    dup layout-class-offset tuple-instance? ;
+    dup echelon-of layout-class-offset tuple-instance? ;
 
 M: tuple-class (flatten-class) dup set ;
 

core/generic/standard/engines/tuple/tuple.factor

@@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ;
     \ <tuple-dispatch-engine> convert-methods ;
 
 M: trivial-tuple-dispatch-engine engine>quot
+    [ n>> ] [ methods>> ] bi dup assoc-empty? [
+        2drop default get [ drop ] prepend
+    ] [
         [
-        [ n>> nth-superclass% ]
-        [ methods>> engines>quots* linear-dispatch-quot % ] bi
-    ] [ ] make ;
+            [ nth-superclass% ]
+            [ engines>quots* linear-dispatch-quot % ] bi*
+        ] [ ] make
+    ] if ;
 
 : hash-methods ( n methods -- buckets )
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
@@ -119,11 +123,19 @@ M: echelon-dispatch-engine engine>quot
     ] assoc-map
     alist>quot ;
 
+: simplify-echelon-alist ( default alist -- default' alist' )
+    dup empty? [
+        dup first first 1 <= [
+            nip unclip second swap
+            simplify-echelon-alist
+        ] when
+    ] unless ;
+
 : echelon-case-quot ( alist -- quot )
     #! We don't have to test for echelon 1 since all tuple
     #! classes are at least at depth 1 in the inheritance
     #! hierarchy.
-    dup first first 1 = [ unclip second ] [ default get ] if swap
+    default get swap simplify-echelon-alist
     [
         [
             picker %
@@ -140,8 +152,11 @@ M: tuple-dispatch-engine engine>quot
             echelons>> unclip-last
             [
                 [
-                    engine>quot define-engine-word
+                    engine>quot
+                    over 0 = [
+                        define-engine-word
                         [ remember-engine ] [ 1quotation ] bi
+                    ] unless
                     dup default set
                 ] assoc-map
             ]