From 14a4535ad9f61f2d1d6c87b534417ec70fe1c7c9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Nov 2009 03:01:22 -0600
Subject: [PATCH] classes.algebra: output cleaner anonymous unions and
 intersections

---
 core/classes/algebra/algebra-tests.factor |  5 +++++
 core/classes/algebra/algebra.factor       | 12 +++++++++---
 2 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index c56ceb7bce..e2f4d4305f 100644
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -37,6 +37,8 @@ INTERSECTION: empty-intersection ;
 
 INTERSECTION: generic-class generic class ;
 
+UNION: union-with-one-member a ;
+
 ! class<=
 [ t ] [ \ fixnum \ integer class<= ] unit-test
 [ t ] [ \ fixnum \ fixnum class<= ] unit-test
@@ -122,6 +124,9 @@ INTERSECTION: generic-class generic class ;
 [ t ] [ generic-class generic class<= ] unit-test
 [ t ] [ generic-class \ class class<= ] unit-test
 
+[ t ] [ a union-with-one-member class<= ] unit-test
+[ f ] [ union-with-one-member class-not integer class<= ] unit-test
+
 ! class-and
 : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
 
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 5ae4f03598..c08239849f 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -9,11 +9,14 @@ IN: classes.algebra
 
 TUPLE: anonymous-union { members read-only } ;
 
-C: <anonymous-union> anonymous-union
+: <anonymous-union> ( members -- class )
+    [ null eq? not ] filter prune
+    dup length 1 = [ first ] [ anonymous-union boa ] if ;
 
 TUPLE: anonymous-intersection { participants read-only } ;
 
-C: <anonymous-intersection> anonymous-intersection
+: <anonymous-intersection> ( participants -- class )
+    prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
 
 TUPLE: anonymous-complement { class read-only } ;
 
@@ -114,6 +117,7 @@ M: word valid-class? drop f ;
             [ class-not normalize-class ] map
             <anonymous-union>
         ] }
+        [ <anonymous-complement> ]
     } cond ;
 
 : left-anonymous-complement<= ( first second -- ? )
@@ -133,8 +137,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
 
 : (class<=) ( first second -- ? )
     2dup eq? [ 2drop t ] [
+        [ normalize-class ] bi@
         2dup superclass<= [ 2drop t ] [
-            [ normalize-class ] bi@ {
+            {
+                { [ 2dup eq? ] [ 2drop t ] }
                 { [ dup empty-intersection? ] [ 2drop t ] }
                 { [ over empty-union? ] [ 2drop t ] }
                 { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }