;; assuming that the types are arranged in a simple tower shape.
(define(apply-generic op . args);; raise s into t, if success, return s; else return #f
(define(raise-into s t)(let((s-type (type-tag s))(t-type (type-tag t)))(cond((equal? s-type t-type) s)((get 'raise (list s-type))(raise-into ((get 'raise (list s-type))(contents s)) t))(else#f))))(let((type-tags (map type-tag args)))(let((proc (get op type-tags)))(if proc
(apply proc (map contents args))(if(=(length args) 2)(let((a1 (car args))(a2 (cadr args)))(cond((raise-into a1 a2)(apply-generic op (raise-into a1 a2) a2))((raise-into a2 a1)(apply-generic op a1 (raise-into a2 a1)))(else(error "No method for these types"(list op type-tags)))))(error "No method for these types"(list op type-tags)))))))
;; this solution is for an apply-generic that works with arbitrary arguments by raising all to the highest type
(define(apply-generic op . args)(let((type-tags (map type-tag args)))(let((proc (get op type-tags)))(if proc
(apply proc (map contents args))(if(>(length args) 1)(let((raised-args (raise-to-common args)))(if raised-args
(let((proc (get op (map type-tag raised-args))))(if proc
(apply proc (map contents raised-args))(error "No method for these types"(list op type-tags))))(error "No method for these types"(list op type-tags))))(error "No method for this type"(list op type-tags)))))))(define(raise-to-common args)(let((raised-args (map(lambda(x)(raise-to-type (top-type-of args) x))
args)))(if(all-true raised-args) raised-args
false)))(define(raise-to-type type item)(let((item-type (type-tag item)))(if(eq? item-type type) item
(let((raise-fn (get-raise item-type)))(if raise-fn (raise-to-type type (raise-fn item))
false)))))(define(top-type-of args)(if(null?(cdr args))(type-tag (car args))(let((t1 (type-tag (car args)))(t2 (top-type-of (cdr args))))(let((l1 (get-level t1))(l2 (get-level t2)))(if(> l1 l2) t1 t2)))))
gws