Permalink
Browse files

om.support: set-like* and union*

  • Loading branch information...
k7f committed Feb 3, 2012
1 parent 848805c commit 374af3d60faffc4042bc7f465e86698a88331a0e
Showing with 36 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +21 −0 work/om/support/support-docs.factor
  3. +14 −0 work/om/support/support.factor
View
@@ -1,3 +1,4 @@
*~
ref/
+work/todo/
work/use/
@@ -324,6 +324,25 @@ HELP: members*
{ $description "Like " { $link sets:members } ", but equality test may be arbitrary, instead of the hard-coded " { $link = } " operator." }
{ $see-also "lisp-alikes" } ;
+HELP: set-like*
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation "( obj1 obj2 -- ? )" } }
+ { "exemplar" sets:set }
+ { "set" sets:set }
+}
+{ $description "Like " { $link sets:set-like } ", but equality test may be arbitrary, instead of the hard-coded " { $link = } " operator." } ;
+
+HELP: union*
+{ $values
+ { "seq1" sequence }
+ { "seq2" sequence }
+ { "quot" { $quotation "( obj1 obj2 -- ? )" } }
+ { "seq'" sequence }
+}
+{ $description "Like " { $link sets:union } ", but equality test may be arbitrary, instead of the hard-coded " { $link = } " operator." }
+{ $see-also "lisp-alikes" } ;
+
HELP: >power-of-2
{ $values
{ "m" "a non-negative " { $link integer } }
@@ -379,7 +398,9 @@ $nl
{ { "keyword " { $snippet "&rest" } } { } { $link &rest>sequence } { $url "clhs.lisp.se/Body/03_dac.htm" } }
{ { "quoted list expression " { $snippet "'(...)" } } { $link POSTPONE: '( } { } { $url "clhs.lisp.se/Body/02_dc.htm" } }
{ { "system class " { $snippet "SYMBOL" } } { $link cl-symbol } { } { $url "clhs.lisp.se/Body/t_symbol.htm" } }
+ { { "function " { $snippet "identity" } } { $link cl-identity } { } { $url "clhs.lisp.se/Body/f_identi.htm" } }
{ { "function " { $snippet "remove-duplicates" } " with " { $snippet ":test" } " argument" } { $link members* } { } { $url "clhs.lisp.se/Body/f_rm_dup.htm" } }
+ { { "function " { $snippet "union" } " with " { $snippet ":test" } " argument" } { $link union* } { } { $url "clhs.lisp.se/Body/f_unionc.htm" } }
{ { "function " { $snippet "floor" } } { $link cl-floor } { } { $url "clhs.lisp.se/Body/f_floorc.htm" } }
} ;
@@ -268,6 +268,18 @@ PRIVATE>
: members* ( seq quot: ( obj1 obj2 -- ? ) -- seq' )
[ (members*) ] curry keep like ; inline
+! __________________________
+! a variant of sets:set-like
+
+: set-like* ( seq quot: ( obj1 obj2 -- ? ) exemplar -- seq' )
+ [ members* ] dip like ; inline
+
+! _______________________
+! a variant of sets:union
+
+: union* ( seq1 seq2 quot: ( obj1 obj2 -- ? ) -- seq' )
+ swap over 2dup swap [ [ members* ] 2bi@ append ] 2dip set-like* ; inline
+
! ____
! math
@@ -277,6 +289,8 @@ PRIVATE>
: cl-floor ( num div -- quo rem )
2dup / floor [ * - ] [ >integer ] bi swap ;
+: cl-identity ( x -- x ) ;
+
! _________
! find-tail

0 comments on commit 374af3d

Please sign in to comment.