[plt-scheme] define-macro defining define-macro

>>>>> "Stephen" == Stephen De Gabrielle <spdegabrielle at gmail.com> writes:

    Stephen> ;;in scheme
    Stephen> (define-macro (defspel . arguments)
    Stephen>   `(define-macro , at arguments))

OK, I'm going to spare you the rant about how define-macro
is fundamentally broken :)

What I will do, though, is tempt you with the beauty and
simplicity of syntax-rules.  Let's change that definition
to:

  (define-syntax defspel
    (syntax-rules ()
      ((defspel (name args ...) body ...)
       (define-syntax name
         (syntax-rules ()
           ((name args ...) body ...))))))

Now, superficially that looks more complex, but then when we
start defining spels we get:

  (defspel (walk direction)
    (walk-direction 'direction))

That's already looking a little nicer - no quasiquotes or
commas, we just rewrite what we want it to turn into and put
in a quote where we don't want something evaluated.

But the real beauty is when we get to:

  (defspel (game-action command subj obj place rest ...)
    (defspel (command subject object)
      (cond ((and (eq? *location* 'place)
                  (eq? 'subject 'subj)
                  (eq? 'object 'obj)
                  (have? 'subj))
             rest ...)
            (else '(i cant command like that)))))

Compared to the original, that's a million times more
readable.  Again, not a single quasiquote or comma, and a
defspel defining defspel doesn't change anything.  You still
just write exactly what you want, and quote (one time)
whatever it is you don't want evaluated.  It's like magic -
which is what spels should be all about :)

-- 
Alex

P.S. The whole spels tutorial is somewhat contrived because
it's fundamentally about things that don't need or benefit
from macros, but it is kind of fun.

P.P.S. Full translation of the tutorial follows.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utils from SRFI-1
(define first car)
(define second cadr)
(define third caddr)
(define (append-map f ls)
  (apply append (map f ls)))
(define (filter f ls)
  (cond ((null? ls) '())
        ((f (first ls)) (cons (car ls) (filter f (cdr ls))))
        (else (filter f (cdr ls)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the world

(define *objects*
  '(whiskey-bottle bucket frog chain))

(define *map*
  '((living-room (you are in the living-room of a wizards house. there is a wizard snoring loudly on the couch.)
                 (west door garden)
                 (upstairs stairway attic))
    (garden (you are in a beautiful garden. there is a well in front of you.)
            (east door living-room))
    (attic (you are in the attic of the wizards house. there is a giant welding torch in the corner.)
           (downstairs stairway living-room))))

(define *object-locations*
  '((whiskey-bottle living-room)
    (bucket living-room)
    (chain garden)
    (frog garden)))

(define *location* 'living-room)

(define *chain-welded* #f)
(define *bucket-filled* #f)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; functions

(define (describe-location location map)
  (second (assoc location map)))

(define (describe-path path)
  `(there is a ,(second path) going ,(first path) from here.))

(define (describe-paths location map)
  (append-map describe-path (cddr (assoc location map))))

(define (is-at? obj loc obj-loc)
  (eq? (second (assoc obj obj-loc)) loc))

(define (describe-floor loc objs obj-loc)
  (append-map (lambda (x) `(you see a ,x on the floor.))
              (filter (lambda (x) (is-at? x loc obj-loc))
                      objs)))

(define (look)
  (append (describe-location *location* *map*)
          (describe-paths *location* *map*)
          (describe-floor *location* *objects* *object-locations*)))

(define (walk-direction direction)
  (let ((next (assoc direction (cddr (assoc *location* *map*)))))
    (cond (next (set! *location* (third next)) (look))
          (else '(you cant go that way.)))))

(define (pickup-object object)
  (cond ((is-at? object *location* *object-locations*)
         (set! *object-locations*
               (cons (list object 'body) *object-locations*))
         `(you are now carrying the ,object))
        (else '(you cannot get that.))))

(define (inventory)
  (filter (lambda (x) (is-at? x 'body *object-locations*))
          *objects*))

(define (have? object)
  (member object (inventory)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; spels!

(define-syntax defspel
  (syntax-rules ()
    ((defspel (name args ...) body ...)
     (define-syntax name
       (syntax-rules ()
         ((name args ...) body ...))))))

(defspel (walk direction)
  (walk-direction 'direction))

(defspel (pickup object)
  (pickup-object 'object))

(defspel (game-action command subj obj place rest ...)
  (defspel (command subject object)
    (cond ((and (eq? *location* 'place)
                (eq? 'subject 'subj)
                (eq? 'object 'obj)
                (have? 'subj))
           rest ...)
          (else '(i cant command like that)))))

(game-action weld chain bucket attic
             (cond ((have? 'bucket)
                    (set! *chain-welded* #t)
                    '(the chain is now securely welded to the bucket.))
                   (else '(you do not have a bucket.))))

(game-action dunk bucket well garden
             (cond (*chain-welded*
                    (set! *bucket-filled* #t)
                    '(the bucket is now full of water))
                   (else '(the water level is too low to reach.))))

(game-action splash bucket wizard living-room
             (cond
              ((not *bucket-filled*)
               '(the bucket has nothing in it.))
              ((have? 'frog)
               '(the wizard awakens and sees that you stole his frog. 
                     he is so upset he banishes you to the 
                     netherworlds- you lose! the end.))
              (else
               '(the wizard awakens from his slumber and greets you warmly. 
                     he hands you the magic low-carb donut- you win! the end.)
               )))