multimethods

picoLisp does not have multimethods. Sometimes, they are useful tool which can be implemented as described here. See for example Wikipedia for more information on multimethods.

Suppose we have some classes and we want to define a function/method with behavior depending on the type of arguments. We could use:

a cond statement with isa test or
the Visitor pattern if our language supports singe dispatch only.

However, the most convenient approach is to use multimethods, as implemented in CLOS for example. I will not go that far though.

So we want to achieve the following (dmm stands for define multimethod):

(class +Asteroid)
(class +Spaceship)

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prinl "AA"))

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prinl "AS"))

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prinl "SA"))

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prinl "SS"))

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(collide< A A) # => AA
(collide< A S) # => AS
(collide< S A) # => SA
(collide< S S) # => SS

We can "simply" define a dispatch table and a function that will look up the the function to handle specific arguments.

(put 'collide< 'mm
   (list
      (cons '((+Asteroid) (+Asteroid)) '((X Y) (prinl "aa")))
      (cons '((+Asteroid) (+Spaceship)) '((X Y) (prinl "as")))
      (cons '((+Spaceship) (+Asteroid)) '((X Y) (prinl "sa")))
      (cons '((+Spaceship) (+Spaceship)) '((X Y) (prinl "ss"))) ) )

...and a function collide< would do the look up and apply.

I will try to be more sophisticated and allow for "don't care" cases, e.g. where any of the arguments can be of any type:

      (cons '((+Asteroid) NIL) '((X Y) (prinl "a?")))

Here NIL means "don't care" or that the argument can be of any type.

Lets define a few useful functions:

(de mmApplicable (K M)
   (use (KK MM)
      (loop
         (NIL (or K M) T)
         (setq KK (pop 'K) MM (pop 'M))
         (NIL (or (not MM) (= KK MM)) NIL))))

(de mmApply @
   (let (N (next) A (rest) K NIL)
      (for AA A
         (push 'K (type AA)))
      (setq K (flip K))
      (let *Mm (filter '((M) (mmApplicable K (car M))) (get N 'mm))
         (ifn *Mm
            (quit 'mm (list "No applicable method" N A K))
            (apply (cdr (pop '*Mm)) A)))))

(de mmDef (N P)
   (let L (get N 'mm)
      (ifn L
         (put N 'mm (list P))
         (use X
            (loop
               (NIL L (put N 'mm (cons P (get N 'mm))))
               (setq X (pop 'L))
               (T (= (car P) (car X)) (con X (cdr P))) ) ) ) ) )

(de dmm A
   (let (N (car A) AA (cadr A) B (cddr A))
      (unless (val N)
         (def N (fill '(@ (pass mmApply 'N)) 'N)) )
      (mmDef N (cons
                  (mapcar '((X) (when (pair X) (cdr X))) AA)
                  (cons (mapcar '((X) (if (pair X) (car X) X)) AA) B) ) ) ) )

Now we can run the following example:

(put 'collide< 'mm
   (list
      (cons '((+Asteroid) (+Asteroid)) '((X Y) (prinl "aa")))
      (cons '((+Asteroid) (+Spaceship)) '((X Y) (prinl "as")))
      (cons '((+Spaceship) (+Asteroid)) '((X Y) (prinl "sa")))
      (cons '((+Spaceship) (+Spaceship)) '((X Y) (prinl "ss")))
      (cons '((+Asteroid) NIL) '((X Y) (prinl "a?")))
      (cons '((+Spaceship) NIL) '((X Y) (prinl "s?")))
      (cons '(NIL (+Asteroid)) '((X Y) (prinl "?a")))
      (cons '(NIL (+Spaceship)) '((X Y) (prinl "?s")))
      (cons '(NIL (+Spaceship)) '((X Y) (prinl "?s")))
      (cons '(NIL NIL) '((X Y) (prinl "??"))) ) )

(class +Asteroid)
(class +Spaceship)

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prinl "AA"))

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prinl "AS"))

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prinl "SA"))

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prinl "SS"))

(dmm collide< (X Y)
   (prinl "bang"))

(collide< A A) # => AA
(collide< A S) # => AS
(collide< S A) # => SA
(collide< S S) # => SS
(collide< A 1) # => a?
(collide< 2 A) # => ?a
(collide< S 3) # => s?
(collide< 4 S) # => ?s
(collide< 5 T) # => bang
(collide< T)   # => bang
(collide<)     # => bang

Notice that we defined the dispatch table first to get the right ordering and then we redefined some methods.

This implementation is not good enough yet though as we have to manually maintain the dispatch table (the proper ordering of methods).

Lets automate dispatch table maintainance and introduce function 'mmNext' equivalent to (call-next-method) in CLOS.

(de subclass? (X Y)
   (if (pair Y)
      (loop
         (NIL Y T)
         (NIL (subclass? X (pop 'Y))) )
      (let Q (if (pair X) X (val X)) # dfs
         (use H
            (loop
               (NIL Q)
               (setq H (pop 'Q))
               (T (= H Y) T)
               (for HH (val H)
                  (push 'Q HH) ) ) ) ) ) )

(de mmApplicable (K M)
   (use (KK MM)
      (loop
         (NIL (or K M) T)
         (setq KK (pop 'K) MM (pop 'M))
         (NIL (or (not MM) (= KK MM) (subclass? KK MM)) NIL) ) ) )

(de mmApply @
   (let ("N" (next)
         "A" (rest)
         "K" (mapcar type "A")
         "Mm" (filter '((M) (mmApplicable "K" (car M))) (get "N" 'mm)) )
      (ifn "Mm"
         (quit 'mm (list "No applicable method" "N" "A" "K"))
         (let mmNext '(()
                       (ifn (cdr (pop '"Mm"))
                          (quit 'mm (list "No other method" "N" "A" "K"))
                          (apply @ "A") ) )
            (apply (cdr (pop '"Mm")) "A") ) ) ) )

(de mmDef (N P)
   (let L (get N 'mm)
      (ifn L
         (put N 'mm (list P))
         (use X
            (loop
               (NIL L (put N 'mm (mmSort (cons P (get N 'mm)))))
               (setq X (pop 'L))
               (T (= (car P) (car X)) (con X (cdr P))) ) ) ) ) )

(de dmm A
   (let (N (car A) AA (cadr A) B (cddr A))
      (unless (val N)
         (def N (fill '(@ (pass mmApply 'N)) 'N)) ) # bug shared!?
      (mmDef N (cons
                  (mapcar '((X) (when (pair X) (cdr X))) AA)
                  (cons (mapcar '((X) (if (pair X) (car X) X)) AA) B) ) ) ) )

(de mmLt (L R)
   (use (LH RH)
      (loop
         (NIL (or L R))
         (setq LH (pop 'L) RH (pop 'R))
         (T (and (not LH) RH) NIL)
         (T
          (when LH
             (or (not RH) (and (<> LH RH) (subclass? LH RH))) )
          T ) ) ) )

(de mmSort (L)
   (order L '((L R) (mmLt (car L) (car R)))) )

(de order (Lst Lt) # TODO built-in or better sort log(N) instead of N^2
   (let Q NIL
      (for X Lst
         (let S 0
            (for Y Lst
               (when (apply Lt NIL (car X) (car Y))
                  (inc 'S) ) )
            (push 'Q (cons S X))) )
      (flip (mapcar cdr (by car sort Q))) ) )

We introduced the predicate 'subclass?' which uses depth-first search in the superclass tree. We also modified slightly 'mmApplicable', 'mmApply' and 'mmDef' functions. The new functions 'mmLt', 'order' and 'mmSort' are for dispatch table ordering.

We can use the code as follows:

(class +Asteroid)
(class +Spaceship)

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(dmm collide< (X Y)
   (prin "?? Bang, what happened? ")
   (println X Y) )

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prin "AA Look at the beautiful fireworks! ")
   (println X Y) )

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prin "AS Is it fatal? ")
   (println X Y) )

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prin "SA Is it fatal? ")
   (println X Y) )

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prin "SS Who's fault was it? ")
   (println X Y) )

(collide< A A) # AA Look at the beautiful fireworks! $519672026 $519672026
(collide< A S) # AS Is it fatal? $519672026 $519672040
(collide< S A) # SA Is it fatal? $519672040 $519672026
(collide< S S) # SS Who's fault was it? $519672040 $519672040
(collide< A 1) # ?? Bang, what happened? $519672026 1
(collide< 2 A) # ?? Bang, what happened? 2 $519672026
(collide< S 3) # ?? Bang, what happened? $519672040 3
(collide< 4 S) # ?? Bang, what happened? 4 $519672040
(collide< 5 T) # ?? Bang, what happened? 5 T
(collide< T)   # ?? Bang, what happened? T NIL
(collide<)     # ?? Bang, what happened? NIL NIL

...or try the bank account example from PAIP:

(class +Acc)                        # account
(class +LtdAcc +Acc)                # account with withdrawal limit

(dmm withdraw< ((A +Acc) Amt)
   (with A
      (if (< (: bal) Amt)
         'insufficient-funds
         (dec (:: bal) Amt) ) ) )

(dmm withdraw< ((A +LtdAcc) Amt)
   (with A
      (if (< (: lim) Amt)
         'over-limit
         (mmNext) ) ) )

(setq F (new '(+Acc) 'nm "Fred" 'bal 5000 'irt 6))
(setq G (new '(+LtdAcc) 'nm "George" 'bal 4000 'irt 5 'lim 1000))

(withdraw< F 6000) # -> insufficient-funds
(withdraw< F 1000) # -> 4000
(withdraw< G 2000) # -> over-limit
(withdraw< G 200)  # -> 3800

There are some improvements that could be implemented:

Add before, after and around methods as in CLOS
Undefine methods
Dispatch on value, e.g. (dmm collide< ((A +Asteroid) (B (= "Bill"))) ...).
Add other types to dispatch on, e.g. atom pair num sym etc., e.g. (dmm collide< ((A +Asteroid) (B pair)) ...)
more types: num sym atom pair T NIL null etc.

Note that we cannot add a dispatch on any user defined predicate as we would not be able to sort the dispatch table automatically.

picoWiki pages can be edited by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively