传说中的DSL

Published on Jun 16, 2012

lisp中的dsl

什么是dsl,为什么要dsl

显然对于特定的领域,特定的程序是更好的解决方案,这个程序就是DSL[1].lisp非常方便来实现DSL。在land of lisp一书中进行了两种dsl,一种是生成xml或html,另一种是对我们之前wizard游戏的中的游戏命令进行dsl。

生成svg文件

关于svg文件不加以详述,读者可以参考这里 。这非常重要,只有理解了xml文件的格式才能继续我们的dsl。svg采用xml格式,顺便我们也说说生成网页的dsl。

首先写一个辅助函数,

    ;Creating XML and HTML with the tag Macro
    ;Writing a Macro Helper Function
    (defun print-tag (name alst closingp)
      (princ #\<)
      (when closingp
        (princ #\/))
      (princ (string-downcase name))
      (mapc (lambda (att);使用mapc是为了副作用。它总返回第一个参数
              (format t " ~a=\"~a\"" (string-downcase (car att)) (cdr att)))
            alst)
      (princ #\>))

可以试试

    (print-tag 'mytag '((color . blue) (height . 9)) nil)

然后创造生成标签的宏,宏能在以下几个方面提供不可替代的改善:

  • 标签总是成对的,如果想要嵌套标签,函数办不到。因为它要求我们在嵌套标签被求值之前和之后执行代码。这在宏中是可能的,函数却做不到。
  • 标签名和属性名通常不必通过动态方式改变。因此,把标签名通过单引号引用是多余的。换句话说,标签名应该默认被对待为想数据模式一样。
  • 不像标签名,属性值则应该动态生成。我们的宏将拥有这么一个语法去把属性值放到代码模式,让我们可以执行lisp代码去生成这些值。

总之我们想让我们的宏看上去这样:

    (tag mytag (color 'blue height (+ 4 5)))
    <mytag color="BLUE" height="9"><mytag>

我们这么做:

    (defmacro tag (name atts &body body)
      `(progn (print-tag ',name
                         (list ,@(mapcar (lambda (x)
                                           `(cons ',(car x) ,(cdr x)))
                                         (pairs atts)))
                         nil)
              ,@body
              (print-tag ',name nil t)))

很好的实现了以上要求,可以展开看看:

    (macroexpand '(tag mytag (color 'blue height (+ 4 5))))

可以看看如何实现嵌套的:

    (tag mytag (color 'blue size 'big)
      (tag first_inner_tag ())
      (tag second_inner_tag ()))

我们还可以用来生成html

    (tag html ();比之前我们生成html的版本好看多了……
      (tag body ()
        (princ "Hello World!")))

html的标签是特定的,我们还能为特定的html标签编写宏:

    (defmacro html (&body body)
      `(tag html ()
         ,@body))
    (defmacro body (&body body)
      `(tag body ()
         ,@body))
    (html (body (princ "Hi boys")))

好了,不跑题了,开始写生成svg的宏

    ;Creating SVG-Specific Macros and Functions 
    (defmacro svg (&body body)
      `(tag svg (xmlns "http://www.w3.org/2000/svg";声明标准在哪里
                 "xmlns:xlink" "http://www.w3.org/1999/xlink");链接
            ,@body))

写一个函数专门加深色彩,方便我们绘图

    (defun brightness (col amt)
      (mapcar (lambda (x)
                (min 255 (max 0 (+ x amt))))
              col))
    (brightness '(255 0 0) -100)

使用一个svg样式函数生成颜色属性,边比内部颜色深.注意~{和~}可以起遍历的作用。

    (defun svg-style (color)
      (format nil
              "~{fill:rgb(~a,~a,~a);stroke:rgb(~a,~a,~a)~}"
              (append color;边界比内部颜色更深
                      (brightness color -100))))

于是得到生成圆的一个函数

    (defun circle (center radius color)
      (tag circle (cx (car center)
                      cy (cdr center)
                      r radius
                      style (svg-style color))))

最后可以简单的得到svg文件

    (svg (circle '(50 .50) 50 '(255 0 0))
         (circle '(100 . 100) 50 '(0 0 255)))

还可以写些更复杂的svg例子,比如一个多边形

    ;Building a More Complicated SVG Example
    (defun polygon (points color)
      (tag polygon (points (format nil
                                   "~{~a,~a ~}";~{允许我们迭代
                                   (mapcan (lambda (tp)
                                             (list (car tp) (cdr tp)));mapcan是有append的mapcar
                                           points))
                           style (svg-style color))))

写个random-walk函数,我想读者应该知道是干什么的

    (defun random-walk (value length)
      (unless (zerop length)
        (cons value
              (random-walk (if (zerop (random 2))
                             (1- value)
                             (1+ value))
                           (1- length)))))
    (random-walk 100 10);测试

写进一个文件

    (with-open-file (*standard-output* "random_walk.svg"
                                       :direction :output
                                       :if-exists :supersede)
      (svg (loop repeat 10
                 do (polygon (append '((0 . 200))
                                     (loop for x;又是这种风格,sbcl识别不了啊
                                           for y in (random-walk 100 400)
                                           collect (cons x y))
                                     '((400 . 200)))
                             (loop repeat 3
                                   collect (random 256))))))

用你的浏览器打开random\walk.svg看看吧,生成大概这样的图像: “random\walk”:/images/random\walk.svg

对先前的游戏进行dsl

首先别忘了加载那个游戏

    ;Creating Custom Game Commands for Wizard's Adventure Game
    (load "wizards_game")

添加两个命令,一个把链条和篮子焊接在一起,另一个用焊好的篮子从井里打水。

    ;Creating New Game Commands by Hand
    ;A Command for Welding
    (defun have (object)
      (member object (inventory)))
    (defparameter *chain-welded* nil)
    (defun weld (subject object)
      (if (and (eq *location* 'attic)
               (eq subject 'chain)
               (eq obejct 'bucket)
               (have 'chain)
               (have 'bucket)
               (not *chain-welded*))
        (progn (setf *chain-welded* t)
               '(the chain is now securely welded to the bucket.))
        '(you cannot weld like that)))
    (weld 'chain 'bucket)
    ;(game-repl)
    (pushnew 'weld *allowed-commands*);这很关键,不是吗?
    ;A Command for Dunking
    (setf *bucket-filled* nil)

    (defun dunk (subject object)
      (if (and (eq *location* 'garden)
               (eq subject 'bucket)
               (eq object 'well)
               (have 'bucket)
               *chain-welded*)
        (progn (setf *bucket-filled* 't)
               '(the bucket is now full of water))
        '(you cannot dunk like that.)))
    (pushnew 'dunk *allowed-commands*)

发现没?这两种命令很相似,我们来dsl,重新用我们的宏来重新添加上两个命令,另为我们还添加了一个更复杂的命令splash,把水泼到巫师脸上……

    ;The game-action Macro
    (defmacro game-action (command subj obj place &body body)
      (let1 subject (gensym) (let1 object (gensym) 
      `(progn (defun ,command (,subject ,object)
                (if (and (eq *location* ',place)
                         (eq ,subject ',subj)
                         (eq ,object ',obj)
                         (have ',subj))
                ,@body 
                '(i cant ,command like that.)))
      (pushnew ',command *allowed-commands*)))))
    ;rewrite
    (defparameter *chain-welded* nil)
    (game-action weld chain bucket attic
      (if (and (have 'bucket) (not *chain-welded*))
        (progn (setf *chain-welded* 't)
               '(the chain is now securely welded to the bucket.))
        '(you do not have a bucket.)))
    (setf *bucket-filled* nil)
    (game-action dunk bucket well garden
      (if *chain-welded*
        (progn (setf *bucket-filled* 't)
               '(the bucket is now full of water))
        '(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.))
            (t '(the wizard awakens from his slumber and greets you warmly.
                     he hands you the magic low-carb donut- you win! the end.))))

试试我们的新游戏,很棒不是?

    (game-repl)

小结

  • 当你需要一些特定领域的古怪的程序,宏是很棒的方案。通过它们,你可以创建自己的dsl。
  • 通常,首先为宏写一个辅助函数,然后写宏来提供宏能提供的提升。这些提高通常关乎能更清晰更安全地语法来使用代码。
  • 你可以混合DSL和常规Lisp 程序。lisp程序可以更方便你调试。
  • DSL非常有用,当你需要写下非常特定代码-–—无论是生成网页,代码,或是画图,或是建立特殊的游戏命令的代码。

照例的废话

寝室的室友在看dota比赛,不要这么激情好么,吵死了。晚上试着跑了将近一个小时步,感觉不错。