diff options
author | bnewbold <bnewbold@eta.mit.edu> | 2009-05-08 03:35:05 -0400 |
---|---|---|
committer | bnewbold <bnewbold@eta.mit.edu> | 2009-05-08 03:35:05 -0400 |
commit | 2aad489f2c311a8fdfed8419fdf523f055f0296d (patch) | |
tree | 4d21f1ad6768f9fb4b3c9e2307c9e3d13e0c882a /final_project/work/discovery.scm | |
parent | beaad775a6621f0896f0f5b9b40bd9e25ec9d8c7 (diff) | |
download | 6.945-2aad489f2c311a8fdfed8419fdf523f055f0296d.tar.gz 6.945-2aad489f2c311a8fdfed8419fdf523f055f0296d.zip |
oh yeah
Diffstat (limited to 'final_project/work/discovery.scm')
-rw-r--r-- | final_project/work/discovery.scm | 59 |
1 files changed, 47 insertions, 12 deletions
diff --git a/final_project/work/discovery.scm b/final_project/work/discovery.scm index 3fa138f..e3756ab 100644 --- a/final_project/work/discovery.scm +++ b/final_project/work/discovery.scm @@ -9,6 +9,8 @@ ; If it isn't already.... ;(load "ghelper") +(define filter keep-matching-items) + ; takes two lists: the first is a set of predicates and the second a set ; of arguments; if any of the predicates are #t for the args, win, else fail (define (for-any? preds args) @@ -137,21 +139,54 @@ -------------------- End Testing ------------------- |# -(define (discover:apply-all . args) - (filter (compose not null?) - (map (lambda (oper) - (if (symbol? oper) - '() - (list oper (apply oper args)))) - (apply discover:opers-for args)))) +; this is just what operators do +(define (discover:apply-name name . args) + (let ((record (hash-table/get *generic-operator-table* name #f))) + (let ((succeed + (lambda (handler) + (apply handler args)))) + (let per-arg + ((tree (operator-record-tree record)) + (args args) + (fail + (lambda () + (error:no-applicable-methods operator args)))) + (let per-pred ((tree tree) (fail fail)) + (cond ((pair? tree) + (if ((caar tree) (car args)) + (if (pair? (cdr args)) + (per-arg (cdar tree) + (cdr args) + (lambda () + (per-pred (cdr tree) fail))) + (succeed (cdar tree))) + (per-pred (cdr tree) fail))) + ((null? tree) + (fail)) + (else + (succeed tree)))))))) + +(define (discover:thunklist-for . args) + (let ((names (apply discover:named-opers-for args))) + (cons args + (map (lambda (x) + (list x + (lambda () + (apply discover:apply-name (cons x args))))) + names)))) + + + + + + + + + + -(discover:apply-all 2) - -(discover:named-opers-for 2) -(environment-lookup (the-environment) 'sin) -(one-like 4) |