2009-04-24 21:43:01 -04:00
|
|
|
! Copyright (C) 2009 Slava Pestov.
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2009-04-24 21:43:01 -04:00
|
|
|
USING: accessors definitions generic generic.single kernel
|
2009-04-25 20:41:27 -04:00
|
|
|
namespaces words math combinators sequences ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: generic.standard
|
|
|
|
|
2009-04-24 21:43:01 -04:00
|
|
|
TUPLE: standard-combination < single-combination # ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-04-02 03:44:10 -04:00
|
|
|
C: <standard-combination> standard-combination
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-04-02 03:44:10 -04:00
|
|
|
PREDICATE: standard-generic < generic
|
|
|
|
"combination" word-prop standard-combination? ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-04-02 03:44:10 -04:00
|
|
|
PREDICATE: simple-generic < standard-generic
|
2009-04-24 21:43:01 -04:00
|
|
|
"combination" word-prop #>> 0 = ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2009-03-22 19:00:26 -04:00
|
|
|
CONSTANT: simple-combination T{ standard-combination f 0 }
|
|
|
|
|
|
|
|
: define-simple-generic ( word effect -- )
|
|
|
|
[ simple-combination ] dip define-generic ;
|
2008-04-02 03:44:10 -04:00
|
|
|
|
2009-04-24 21:43:01 -04:00
|
|
|
: (picker) ( n -- quot )
|
|
|
|
{
|
|
|
|
{ 0 [ [ dup ] ] }
|
|
|
|
{ 1 [ [ over ] ] }
|
|
|
|
{ 2 [ [ pick ] ] }
|
|
|
|
[ 1- (picker) [ dip swap ] curry ]
|
|
|
|
} case ;
|
2008-04-02 03:44:10 -04:00
|
|
|
|
2009-04-24 21:43:01 -04:00
|
|
|
M: standard-combination picker
|
|
|
|
combination get #>> (picker) ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-04-02 22:27:49 -04:00
|
|
|
M: standard-combination dispatch# #>> ;
|
|
|
|
|
2009-04-25 20:41:27 -04:00
|
|
|
M: standard-generic effective-method
|
|
|
|
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
|
|
|
|
(effective-method) ;
|
|
|
|
|
|
|
|
M: standard-generic definer drop \ GENERIC# f ;
|
2008-01-06 11:13:44 -05:00
|
|
|
|
2009-04-25 20:41:27 -04:00
|
|
|
M: simple-generic definer drop \ GENERIC: f ;
|