! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
USING: arrays errors hashtables kernel kernel-internals lists
namespaces parser sequences strings words vectors math
math-internals ;

! A simple single-dispatch generic word system.

! Maps lists of builtin type numbers to class objects.
SYMBOL: typemap

! Global vector mapping type numbers to builtin class objects.
SYMBOL: builtins

: type>class ( n -- symbol ) builtins get nth ;

: predicate-word ( word -- word )
    word-name "?" append create-in ;

: define-predicate ( class predicate quot -- )
    #! predicate may be f, in which case it is ignored.
    over [
        dupd define-compound
        2dup unit "predicate" set-word-prop
        swap "predicating" set-word-prop
    ] [
        3drop
    ] if ;

: superclass "superclass" word-prop ;

: members "members" word-prop ;

: (flatten) ( class -- )
    dup members [ [ (flatten) ] each ] [ dup set ] ?if ;

: flatten ( class -- classes )
    #! Outputs a sequence of classes whose union is this class.
    [ (flatten) ] make-hash ;

: (types) ( class -- )
    #! Only valid for a flattened class.
    flatten [
        car dup superclass
        [ (types) ] [ "type" word-prop dup set ] ?if
    ] hash-each ;

: types ( class -- types )
    [ (types) ] make-hash hash-keys ;

DEFER: class<

: superclass< ( cls1 cls2 -- ? )
    >r superclass r> over [ class< ] [ 2drop f ] if ;

: (class<) ( cls1 cls2 -- ? )
    [ flatten hash-keys ] 2apply
    swap [ swap [ class< ] contains-with? ] all-with? ;

: class< ( cls1 cls2 -- ? )
    #! Test if class1 is a subclass of class2.
    {
        { [ 2dup eq? ] [ 2drop t ] }
        { [ over flatten hash-size 0 = ] [ 2drop t ] }
        { [ over superclass ] [ >r superclass r> class< ] }
        { [ dup superclass ] [ superclass< ] }
        { [ 2dup [ members ] 2apply or not ] [ 2drop f ] }
        { [ t ] [ (class<) ] }
    } cond ;

: class-compare ( cls1 cls2 -- -1/0/1 )
    2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;

: methods ( generic -- alist )
    "methods" word-prop hash>alist [ 2car class-compare ] sort ;

: order ( generic -- list )
    methods [ car ] map ;

PREDICATE: compound generic ( word -- ? )
    "combination" word-prop ;

M: generic definer drop \ G: ;

: make-generic ( word -- )
    dup dup "combination" word-prop call define-compound ;

: class? ( word -- ? ) "class" word-prop ;

: check-method ( class generic -- )
    dup generic? [
        dup word-name " is not a generic word" append throw
    ] unless
    over "class" word-prop [
        over word-name " is not a class" append throw
    ] unless 2drop ;

: define-method ( definition class generic -- )
    >r reintern r> 2dup check-method
    [ "methods" word-prop set-hash ] keep make-generic ;

: forget-method ( class generic -- )
    [ "methods" word-prop remove-hash ] keep make-generic ;

: init-methods ( word -- )
     dup "methods" word-prop
     [ drop ] [ H{ } clone "methods" set-word-prop ] if ;

! Defining generic words

: bootstrap-combination ( quot -- quot )
    #! Bootstrap hack.
    global [
        [
            dup word? [
                dup word-name swap word-vocabulary lookup
            ] when
        ] map
    ] bind ;

: define-generic* ( word combination -- )
    bootstrap-combination
    dupd "combination" set-word-prop
    dup init-methods make-generic ;

: lookup-union ( class-set -- class )
    #! The class set is a hashtable with equal keys/values.
    typemap get hash [ object ] unless* ;

: (builtin-supertypes) ( class -- )
    dup members [
        [ (builtin-supertypes) ] each
    ] [
        dup superclass [
            (builtin-supertypes)
        ] [
            dup set
        ] ?if
    ] ?if ;

: builtin-supertypes ( class -- classes )
    #! Outputs a sequence of builtin classes whose union is the
    #! smallest union of builtin classes that contains this
    #! class.
    [ (builtin-supertypes) ] make-hash ;

: (class-and) ( class class -- class )
    [ builtin-supertypes ] 2apply hash-intersect lookup-union ;

: class-and ( class class -- class )
    #! Return a class that is a subclass of both, or null in
    #! the degenerate case.
    {
        { [ 2dup class< ] [ drop ] }
        { [ 2dup swap class< ] [ nip ] }
        { [ t ] [ (class-and) ] }
    } cond ;

: classes-intersect? ( class class -- ? )
    class-and flatten hash-size 0 > ;

: min-class ( class seq -- class/f )
    #! Is this class the smallest class in the sequence?
    [ dupd classes-intersect? ] subset
    [ class-compare neg ] sort
    tuck [ class< ] all-with? [ first ] [ drop f ] if ;

: define-class ( class -- )
    dup t "class" set-word-prop
    dup flatten typemap get set-hash ;

: implementors ( class -- list )
    #! Find a list of generics that implement a method
    #! specializing on this class.
    [ "methods" word-prop ?hash ] word-subset-with ;

: classes ( -- list )
    #! Output a list of all defined classes.
    [ class? ] word-subset ;

! Predicate classes for generalized predicate dispatch.
: define-predicate-class ( class predicate definition -- )
    pick define-class
    3dup nip "definition" set-word-prop
    pick superclass "predicate" word-prop
    [ \ dup , % , [ drop f ] , \ if , ] [ ] make
    define-predicate ;

PREDICATE: word predicate "definition" word-prop ;

! Union classes for dispatch on multiple classes.
: union-predicate ( members -- list )
    [
        "predicate" word-prop \ dup swons [ drop t ] cons
    ] map [ drop f ] swap alist>quot ;

: set-members ( class members -- )
    [ reintern ] map "members" set-word-prop ;

: define-union ( class predicate members -- )
    #! We have to turn the f object into the f word, same for t.
    3dup nip set-members pick define-class
    union-predicate define-predicate ;

PREDICATE: word union members ;