From b61c41163bf11834611230b14c5b737bd0a5a2be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 6 Jan 2008 00:07:12 -0400
Subject: [PATCH] Inefficient, experimental multi-methods implementation

---
 extra/multi-methods/multi-methods.factor | 53 ++++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100755 extra/multi-methods/multi-methods.factor

diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
new file mode 100755
index 0000000000..bc84b47c8d
--- /dev/null
+++ b/extra/multi-methods/multi-methods.factor
@@ -0,0 +1,53 @@
+USING: kernel math sequences vectors classes combinators
+generic.standard arrays words combinators.lib assocs parser ;
+IN: multi-methods
+
+: maximal-element ( seq quot -- n elt )
+    dupd [
+        swapd [ call 0 < ] 2curry subset empty?
+    ] 2curry find [ "Topological sort failed" throw ] unless* ;
+    inline
+
+: topological-sort ( seq quot -- newseq )
+    >r >vector [ dup empty? not ] r>
+    [ dupd maximal-element >r over delete-nth r> ] curry
+    [ ] unfold nip ; inline
+
+: classes< ( seq1 seq2 -- -1/0/1 )
+    [
+        {
+            { [ 2dup eq? ] [ 0 ] }
+            { [ 2dup class< ] [ -1 ] }
+            { [ 2dup swap class< ] [ 1 ] }
+            { [ t ] [ 0 ] }
+        } cond 2nip
+    ] 2map [ zero? not ] find nip 0 or ;
+
+: multi-predicate ( classes -- quot )
+    dup length <reversed> [
+        >r "predicate" word-prop r>
+        (picker) swap append
+    ] 2map [ && ] curry ;
+
+: multi-dispatch-quot ( methods -- quot )
+    [ >r multi-predicate r> ] assoc-map
+    [ "No method" throw ] swap reverse alist>quot ;
+
+: sorted-methods ( word -- methods )
+    "multi-methods" word-prop >alist
+    [ [ first ] 2apply classes< ] topological-sort ;
+
+: make-generic ( word -- )
+    dup sorted-methods multi-dispatch-quot define ;
+
+: GENERIC:
+    CREATE
+    dup H{ } clone "multi-methods" set-word-prop
+    make-generic ; parsing
+
+: add-method ( quot classes word -- )
+    [ "multi-methods" word-prop set-at ] keep make-generic ;
+
+: METHOD:
+    parse-definition unclip swap unclip swap spin
+    add-method ; parsing