What these two commits implement:

1. Now avy-goto-char-timer may read one or as many chars as you want given that the respective next char is typed within avy-timeout-seconds.
2. DEL deletes the last character from the input, so that you can fix typos easily without having to abort and invoke avy-goto-char-timer once again.
3. RET immediately stops reading more chars without waiting for another avy-timeout-seconds.
4. Most importantly: the matches of the current input chars are immediately highlighted to give you direct visual feedback.

Here’s a screencast of the new behavior.

BTW, thanks a lot for camcorder.el, Artur!

UPDATE: The PR has already been merged, so you can now use this feature by updating your avy copy from MELPA.

So here’s a command which lets you use drag one buffer from one window to the other. The effect is that the buffers of the start and target window are swapped.

(defun th/swap-window-buffers-by-dnd (drag-event)
  "Swaps the buffers displayed in the DRAG-EVENT's start and end
window."
  (interactive "e")
  (let ((start-win (cl-caadr drag-event))
        (end-win   (cl-caaddr drag-event)))
    (when (and (windowp start-win)
               (windowp end-win)
               (not (eq start-win end-win))
               (not (memq (minibuffer-window)
                          (list start-win end-win))))
      (let ((bs (window-buffer start-win))
            (be (window-buffer end-win)))
        (unless (eq bs be)
          (set-window-buffer start-win be)
          (set-window-buffer end-win bs))))))

Bind it to some mouse drag event and have fun. For example, I use (global-set-key (kbd "<C-S-drag-mouse-1>") #'th/swap-window-buffers-by-dnd) so that drag’n’drop with the left mouse button and control and shift pressed is bound to the command above.

Given models conforming to the metamodel shown in the following image, the task is to create one Couple node for every pair of persons that acted together in at least three movies.

The Henshin implementation of this transformation is included (currently only in the nightly builds) of the Henshin Example Plugin.

In this blog post, I’m going to compare the Henshin solution with my own solution which is implemented with the in-place transformation API of my model querying and transformation library FunnyQT.

The Transformation Specification

First, let’s have a look at the transformation specifications of both solutions.

The Henshin Transformation

Henshin is a visual graph transformation language for EMF models, i.e., rules are defined as diagrams with a quite good Eclipse-based visual editor.

The transformation consists of one single transformation rule shown below, and one Java class that acts as a test-driver applying the rule to a set of increasingly large models. (In fact, there are actually two more rules that are used to create the test models, but those aren’t important here.)

I don’t want to recap everything Christian said, so here’s a brief overview of the rule’s concepts.

Basically, a rule mimics the structure to be matched in the model using node and edge symbols annotated with either preserve or require stereotypes. During the pattern matching process, an isomorphic mapping from node and edge symbols in the pattern to actual nodes and edges in the model is computed. If such a match can be found, new nodes and edges are created in the model as defined by the elements annotated with create stereotype in the pattern.

That all annotations are starred, e.g., require*, tells Henshin to apply the rule to all matches in one go. The usual graph transformation semantics is to apply a rule just once to some arbitrary match which is found first, and then maybe to iterate the rule application until no more matches can be found. In that case, however, we’d negative application conditions (stereotype forbid) in order not to create new Couple nodes for persons that are already coupled. Therefore, such forall-rules perform better than iterating normal rules, but you can only use them if a rule’s effect does not interfere with what’s matched by the rule, e.g., if a rule can invalidate a later match, a forall-rule won’t do.

The difference between preserve and require is that the former would produce a separate match for any combination of three movies the two persons have in common. However, here we are only interested in the existence of at least three common movies but that’s it. require does exactly that.

However, since both persons are (and need to be because there are incident create edges) annotated with preserve, the Henshin solution actually creates twice as many Couple nodes as are needed because the symmetry of the persons. That is, if two persons P1 and P2 act in at least three movies, one couple node is created for the match (P1, P2) and another one for (P2, P1).

Christian suggests enforcing an alphabetic order using a constraint on attribute values to circumvent that issue. However, the minimal metamodel doesn’t define any attributes for the Person class (or any other class). Of course, a realistic metamodel like the IMDB-based one he talks about would do so.

The FunnyQT Transformation

FunnyQT is a model querying and transformation library implemented in the functional Lisp-dialect Clojure. FunnyQT has several sub-APIs (namespaces) for different querying and transformation tasks. For example, there’s a usual out-place model-to-model transformation API (namespace funnyqt.model2model), a bidirectional transformation API (namespace funnyqt.bidi), and several more.

FunnyQT supports EMF models just like Henshin, but it also supports JGraLab TGraphs. Furthermore, it’s designed with extensibility in mind, so most parts are realized generically using Clojure protocols that can be extended dynamically to other model representations without having to touch FunnyQT’s internals (or the classes of the other model representation).

Since FunnyQT is a Clojure library, queries and transformations are just Clojure code. But as a Lisp-dialect, Clojure provides strong metaprogramming capabilities (macros) that FunnyQT uses to provide several task-oriented embedded (or internal) DSLs to the transformation developer.

Ok, that said, here goes the transformation specification. The solution project is also published in this github project.

The first thing one usually does is to define a namespace for the transformation which requires the needed parts of FunnyQT.

(ns ^{:pattern-expansion-context :emf}
  funnyqt-movie-couples.core
  (:require [clojure.set      :as set]
            [funnyqt.emf      :as emf]
            [funnyqt.in-place :as ip]))

So the name of the transformation namespace is funnyqt-movie-couples.core, and we’re requiring the Clojure namespace clojure.set plus the two FunnyQT namespaces funnyqt.emf and funnyqt.in-place. clojure.set provides functions on sets like intersection, funnyqt.emf provides functions for accessing EMF model elements, and funnyqt.in-place provides constructs for graph transformation-like in-place transformations.

The :as clauses define short aliases for the required namespaces. So their functions need to be qualified (making it obvious where a function called in this namespace originates from), but the qualification can be done with the short alias instead of the complete fully qualified namespace name.

The strange notation ^{:pattern-expansion-context :emf} is a Clojure metadata annotation attached to the namespace name. This concrete one tells FunnyQT that all transformation rules defined in this namespace should expand to pattern matching code suitable for EMF models.

Like the Henshin solution, the FunnyQT solution consists of one single rule shown in the next listing.

(ip/defrule ^:forall make-couples [m]
  [p1<Person> -<movies>-> <> -<persons>-> p2
   :when (and (not (identical? p1 p2))
              (three-common-movies? p1 p2))
   :as #{p1 p2}
   :distinct]
  (emf/ecreate! m 'Couple :p1 p1 :p2 p2))

The macro funnyqt.in-place/defrule defines an in-place transformation rule given a name (make-couples), an argument vector ([m]) where the first argument has to be the model, a pattern vector ([p1...]), and arbitrarily many actions that should be executed on a match ((emf/ecreate ...)).

The ^:forall metadata annotation attached to the rule’s name is FunnyQT’s equivalent to the starred stereotypes in Henshin, that is, when this rule gets applied it takes action on all matches in the model m in one go.

The structural part of the pattern (p1<Person> -<movies>-> <> -<persons>-> p2) defines that the rule matches a Person node p1 that’s connected to some other node p2 via a path of first a movies reference to some arbitrary intermediate node and then a persons reference to p2. In simple words, it defines that the persons p1 and p2 act together in some movie. Note that except for p1 there are no types declared because those are clear from the metamodel anyway. Adding the type Movie to the anonymous intermediate node and Person to p2 wouldn’t change any semantics.

In contrast to Henshin, FunnyQT’s pattern matching facilities default to homomorphic matching rather than isomorphic matching. That is, matches where p1 is matched to the very same node in the model as p2 are perfectly valid. Therefore, the pattern contains a :when constraint ensuring that p1 and p2 are not identical.

Furthermore, the structural part of the pattern just says that there is at least one movie where p1 and p2 act together, not three of them. So that additional constraint is handled by another predicate three-common-movies? that’s going to be discussed below.

You still remember that the Henshin solution created twice as many couples as needed because of the symmetry of the two persons? The last two lines of the pattern solve that issue for the FunnyQT solution. The :as clause defines that matches of the pattern should be represented as a set #{p1 p2} (rather than a tuple) thus making the order insignificant. The :distinct modifier then defines that the rule should only be applied to distinct matches.

Such a rule definition done with the funnyqt.in-place/defrule macro expands into a plain Clojure function at compile-time. Thus applying the rule to a given model is just a matter of (make-couples my-model).

The missing part of the solution is the three-common-movies? predicate that returns true only if the given two persons act in at least three common movies.

(defn three-common-movies? [p1 p2]
  (>= (count (set/intersection
              (into #{} (emf/eget-raw p1 :movies))
              (into #{} (emf/eget-raw p2 :movies))))
      3))

The predicate simply checks is the intersection of p1‘s movies and p2‘s movies is larger than or equal to 3. funnyqt.emf/eget-raw is a function that gets an EObject and a structural feature name given as keyword and returns its value as-is (e.g., as an EList, here). One would usually use funnyqt.emf/eget which does the same but returns the value as a persistent, immutable Clojure data structure in case it’s a collection. Concretely, if the value is an EList, eget would return a Clojure vector. Since we’re coercing to sets anyway, using eget-raw omits a double-conversion.

Performance Comparison

Both the Henshin and the FunnyQT solution perform about equally well. They both scale linearly for the provided test models. Most probably their pattern matching approach is pretty similar. Although not clearly stated in Christian’s blog post linked above, it sounds to me that Henshin’s Giraph code generator generates code that does a breadth- or depth-first search starting at some person node.

FunnyQT patterns are also matched by transforming the textual pattern DSL into a comprehension that effectively does a depth-first search anchored at the node that occurs first in the pattern, i.e., for every Person p1 all nodes p2 connected via one movies reference followed by a persons referenced are searched one after the other.

The following table shows the pure transformation runtimes (excluding model load time, and after a warmup run) for the provided test models ranging from the size of 170,000 nodes to 1,700,000 nodes.

All tests were run on my 5 years old ThinkPad with dual-core 2.1 GHz CPU (but none of the solutions is multi-threaded anyway), and the JVM process was given 2 GB maximal heap space.

Wow, quite good for both. So whatever tool you choose for solving that kind of in-place transformation problems seems to be mostly a matter of if you prefer visual or textual transformation languages.

(Of course, visual languages are for kiddies… SCNR :-P)

So today I’ve thought I should go ahead and add an option to company-mode to trigger completion only if the last command has been an editing command. And guess what, that feature is already there. :-)

(setq company-begin-commands '(self-insert-command))

That will make the company completion trigger only if the last command has been self-insert-command. You can add as many commands as you like there. The default value is t which means to always trigger company completion after company-idle-delay.

With this setting and a very short company-idle-delay (0.3 secs), company-mode now works great for me.

Without further ado, here are completions for git, bzr, and hg. The git completion is basically his completion with some improvements. For example, it completes all git commands by parsing the output of git help --all.

;;**** Git Completion

(defun pcmpl-git-commands ()
  "Return the most common git commands by parsing the git output."
  (with-temp-buffer
    (call-process-shell-command "git" nil (current-buffer) nil "help" "--all")
    (goto-char 0)
    (search-forward "available git commands in")
    (let (commands)
      (while (re-search-forward
	      "^[[:blank:]]+\\([[:word:]-.]+\\)[[:blank:]]*\\([[:word:]-.]+\\)?"
	      nil t)
	(push (match-string 1) commands)
	(when (match-string 2)
	  (push (match-string 2) commands)))
      (sort commands #'string<))))

(defconst pcmpl-git-commands (pcmpl-git-commands)
  "List of `git' commands.")

(defvar pcmpl-git-ref-list-cmd "git for-each-ref refs/ --format='%(refname)'"
  "The `git' command to run to get a list of refs.")

(defun pcmpl-git-get-refs (type)
  "Return a list of `git' refs filtered by TYPE."
  (with-temp-buffer
    (insert (shell-command-to-string pcmpl-git-ref-list-cmd))
    (goto-char (point-min))
    (let (refs)
      (while (re-search-forward (concat "^refs/" type "/\\(.+\\)$") nil t)
	(push (match-string 1) refs))
      (nreverse refs))))

(defun pcmpl-git-remotes ()
  "Return a list of remote repositories."
  (split-string (shell-command-to-string "git remote")))

(defun pcomplete/git ()
  "Completion for `git'."
  ;; Completion for the command argument.
  (pcomplete-here* pcmpl-git-commands)
  (cond
   ((pcomplete-match "help" 1)
    (pcomplete-here* pcmpl-git-commands))
   ((pcomplete-match (regexp-opt '("pull" "push")) 1)
    (pcomplete-here (pcmpl-git-remotes)))
   ;; provide branch completion for the command `checkout'.
   ((pcomplete-match "checkout" 1)
    (pcomplete-here* (append (pcmpl-git-get-refs "heads")
			     (pcmpl-git-get-refs "tags"))))
   (t
    (while (pcomplete-here (pcomplete-entries))))))

;;**** Bzr Completion

(defun pcmpl-bzr-commands ()
  "Return the most common bzr commands by parsing the bzr output."
  (with-temp-buffer
    (call-process-shell-command "bzr" nil (current-buffer) nil "help" "commands")
    (goto-char 0)
    (let (commands)
      (while (re-search-forward "^\\([[:word:]-]+\\)[[:blank:]]+" nil t)
	(push (match-string 1) commands))
      (sort commands #'string<))))

(defconst pcmpl-bzr-commands (pcmpl-bzr-commands)
  "List of `bzr' commands.")

(defun pcomplete/bzr ()
  "Completion for `bzr'."
  ;; Completion for the command argument.
  (pcomplete-here* pcmpl-bzr-commands)
  (cond
   ((pcomplete-match "help" 1)
    (pcomplete-here* pcmpl-bzr-commands))
   (t
    (while (pcomplete-here (pcomplete-entries))))))

;;**** Mercurial (hg) Completion

(defun pcmpl-hg-commands ()
  "Return the most common hg commands by parsing the hg output."
  (with-temp-buffer
    (call-process-shell-command "hg" nil (current-buffer) nil "-v" "help")
    (goto-char 0)
    (search-forward "list of commands:")
    (let (commands
	  (bound (save-excursion
		   (re-search-forward "^[[:alpha:]]")
		   (forward-line 0)
		   (point))))
      (while (re-search-forward
	      "^[[:blank:]]\\([[:word:]]+\\(?:, [[:word:]]+\\)*\\)" bound t)
	(let ((match (match-string 1)))
	  (if (not (string-match "," match))
	      (push (match-string 1) commands)
	    (dolist (c (split-string match ", ?"))
	      (push c commands)))))
      (sort commands #'string<))))

(defconst pcmpl-hg-commands (pcmpl-hg-commands)
  "List of `hg' commands.")

(defun pcomplete/hg ()
  "Completion for `hg'."
  ;; Completion for the command argument.
  (pcomplete-here* pcmpl-hg-commands)
  (cond
   ((pcomplete-match "help" 1)
    (pcomplete-here* pcmpl-hg-commands))
   (t
    (while (pcomplete-here (pcomplete-entries))))))

Update: As Ben pointed out, tis will only work correctly for gzipped text files encoded in UTF-8 as input (ASCII, ISO-5589-1 will also be fine).

(ns foobar
  (:require [clojure.java.io :as io]))

(defn gunzip
  [fi fo]
  (with-open [i (io/reader
                 (java.util.zip.GZIPInputStream.
                  (io/input-stream fi)))
              o (java.io.PrintWriter. (io/writer fo))]
    (doseq [l (line-seq i)]
      (.println o l))))

Ok, so let’s start.  My custom data structures are TGraphs that we develop here at our institute.  You don’t need to know more than that a graph consists of vertices, and vertices can be connected by edges.  Furthermore, both vertices and edges may have attributes.  When you use such a graph, the graph itself, every vertex, and every edge is one Java object in your memory that implements the interface Graph, Vertex, and Edge, respectively.

I wrote a nice functional Clojure API for working with TGraphs (funtg on clojars; don’t use it for serious purposes, I’m constantly changing things without thinking about compatibility at all).  So probably, if you are reading this, you are in the same situation that I was in: You have a cool data structure, you have a cool API for it, and you are totally curious what you could do with core.logic on your data structure.  So how do I get core.logic to work with my stuff???

The answer is: you have to write relations that use your existing API to access your data structure.  The topic of this posting is mainly how to doing that in a way that core.logic wants.  So let’s start with the namespace declaration for the code:

(ns extend.example
  (:refer-clojure :exclude [==])
  (:use [clojure.core.logic])
  ;; The following two are my functional API
  (:require [de.uni-koblenz.ist.funtg.core :as core])
  (:require [de.uni-koblenz.ist.funtg.funql :as funql]))

Nothing special here, except that you can see that I require my functional TGraph API using prefixes.  So when you see core/foo or funql/bar in the following, you know that I’m calling my functional API there.  As next, I added some helper functions for testing if a logic variable is fresh or ground.  Ignore the comment about being walk-ed for now.

(defn fresh?
  "Returns true, if `x' is fresh.
  `x' must have been `walk'ed before!"
  [x]
  (lvar? x))

(defn ground?
  "Returns true, if `x' is ground.
  `x' must have been `walk'ed before!"
  [x]
  (not (lvar? x)))

Then, I’ll defined a constant +graph+ that holds some example TGraph (some route map like graph).  I decided to keep the graph as a var of the namespace instead of making it a parameter of relations, because my API has no way to enumerate all graphs that happen to be in memory.  If the graph was a parameter of relations, I couldn’t be fully relational, e.g., giving only fresh logic variables to my relations would have to error.

(def +graph+ (core/load-graph "/home/horn/Repos/uni/funtg/test/greqltestgraph.tg"))

Now we’ll come to the actual first relation.  vertexo is a relation where v is a vertex in the graph +graph+.

(defn vertexo
  "A relation where `v' is a vertex."
  [v]
  (fn [a]                                 ;; (1)
    (let [gv (walk a v)]
      (if (fresh? gv)
        (to-stream                        ;; (2)
         (->> (map #(unify a v %)
                   (funql/vseq +graph+))
              (remove not)))
         (if (.containsVertex +graph+ gv)
           a
          (fail a))))))

Basically, the stuff marked with (*) is what’s important. (1) A relation must return a function which gets a so-called substitution a. You can think of it as something like an environment map which knows what logical variables are ground, and if so, what value they have. (walk a v) gets you the value of the variable (or value) v. If v is ground, then you get a value back. If v is fresh, you get a logical variable back. So now the functions fresh? and ground? above make sense, right?

The other important part (2) is that the function returned by a relation has to return a substitution again: A relation returns a function that gets a substitution and returns a substitution. to-stream turns a seq into a choice, which essentially say which possible values are allowed for the relation’s parameters. We declare such a possible binding using unify. funql/vseq returns the lazy seq of the graph’s vertices, each of which may be unified with the parameter v in the substitution a. If v was ground, then it could only be unified with the vertex it is already bound to. Because of that, it’s a good idea to filter out false values in the sequence before giving it to to-stream.

If I had put (2) directly into (1), it would work exactly the same. The additional code is for performance purposes. If v is already ground, there’s no reason to try to unify it with every vertex in the graph just to check if it is contained. Instead, a simple check (via the Java API) to see if that vertex is in the graph is enough. If it’s contained, then the substitution a is correct, so I return it “unchanged” (quotes, because of course we don’t mutate in Clojure). Else, the vertex is not in +graph+, so the binding is invalid and we fail.

That’s it. Now let’s turn to edges which are accessed with a relation of 3 parameters denoting the edge itself, its start vertex, and its end vertex.

(defn edgeo
  "A relation where `e' is an edge from `alpha' to `omega'."
  [e alpha omega]
  (fn [a]
    (let [ge     (walk a e)
          galpha (walk a alpha)
          gomega (walk a omega)]
      (cond
        (ground? ge) (unify a [alpha omega]
                            [(core/alpha ge) (core/omega ge)])
        (ground? galpha) (to-stream
                           (->> (map #(unify a [e omega] [% (core/omega %)])
                                     (funql/iseq galpha nil :out))
                                (remove not)))
        (ground? gomega) (to-stream
                           (->> (map #(unify a [e alpha] [% (core/alpha %)])
                                    (funql/iseq gomega nil :in))
                                (remove not)))
        :else (to-stream
                (->> (for [edge (funql/eseq +graph+)]
                       (unify a [e alpha omega]
                              [edge (core/alpha edge) (core/omega edge)]))
                     (remove not)))))))

Again, basically the relation would work fine if we delete everything except the expression of the :else clause.  That unifies all edges in the graph including their start and end vertices with the parameters of the relation.  The three first clauses of the cond are for performance only.  The first says, if an edge is already given, then we only check the start and end vertex, which is a constant time operation.  The second and third clause say, if either the start or end vertex are already given, then we don’t need to unify all edges in the graph with the parameters but only the edges incident to the given vertex (eseq vs. iseq), which is again much faster.

The last relation I’ll show is concerned with attributes.

(defn valueo
  "A relation where `ae' has value `val' for its `at' attribute."
  [ae at val]
  (fn [a]
    (let [gae (walk a ae)
          gat (walk a at)
          gval (walk a val)]
      (cond
        (and (ground? gae)
             (ground? gat)) (or (unify a [ae at val]
                                       [gae gat (core/value gae gat)]))
        (ground? gae) (to-stream
                        (->> (for [attr (seq (.getAttributeList
                                               (core/attributed-element-class gae)))
                                   :let [an (keyword (.getName attr))]]
                                (unify a [ae at val]
                                      [gae an (core/value gae an)]))
                             (remove not)))
        :else (to-stream
                (->> (for [elem (concat (funql/vseq +graph+)
                                        (funql/eseq +graph+))
                           attr (seq (.getAttributeList
                                       (core/attributed-element-class elem)))
                           :let [an (keyword (.getName attr))]]
                        (unify a [ae at val]
                               [elem an (core/value elem an)]))
                     (remove not)))))))

Again, only the :else part is neccessary.  I unify every vertex and every edge together with every attribute that is defined for them with the given parameters.  Clearly, that’s quite some effort.  The first clause of the cond simply looks up the attribute value if the element and the attribute name are already given.  The second clause deals with the case when at least the graph element is given, in which case only all its attribute/value pairs have to be unified.

So here are some example applications.

What are the 3 first vertices in the graph?

(run 3 [q]
  (vertexo q))
;=> (#<v1: localities.Village>
     #<v2: localities.Village>
     #<v3: localities.Town>)

Is this a vertex of the graph?

(let [v1 (core/vertex +graph+ 1)]
  (run* [q]
    (vertexo v1)))
;=> (_.0)     ; succeeded, so yes, it's a vertex of +graph+

What are the first 3 edges of the graph?

(run 3 [q]
  (fresh [a o]
    (edgeo q a o)))
;=> (#<e1: connections.Footpath>
     #<e2: connections.Footpath>
     #<e3: connections.Footpath>)

What edges end at the vertex v1?

(let [v1 (core/vertex +graph+ 1)]
  (run* [q]
    (fresh [o]
      (edgeo q o v1))))
;=> (#<e-22: localities.ContainsLocality>)

Which attribute of what element has the value 251?

(run* [q]
  (fresh [e a]
    (valueo e a 251)
    (== q [e a])))
;=> ([#<v1: localities.Village> :inhabitants])

So that village has 251 inhabitants.  Pretty small.  What’s the name of that village?

(run* [q]
  (fresh [e a]
    (valueo e a 251)
    (valueo e :name q)))
;=> ("Kammerforst")

Ah, it’s Kammerforst.  Oh, wikipedia says its population has increased to 253. ;-)

Ok, that’s it.  I hope this helps you to make your custom data structures work with core.logic. Have fun!

Seems like I am an old fart, totally Web 0.1… ;-)

For example, you edit some file, and then you want to quickly commit it. Using the code below, you can do that like this:

Here’s the code:

(defvar th-shell-popup-buffer nil)

(defun th-shell-popup ()
  "Toggle a shell popup buffer with the current file's directory as cwd."
  (interactive)
  (unless (buffer-live-p th-shell-popup-buffer)
    (save-window-excursion (shell "*Popup Shell*"))
    (setq th-shell-popup-buffer (get-buffer "*Popup Shell*")))
  (let ((win (get-buffer-window th-shell-popup-buffer))
	(dir (file-name-directory (or (buffer-file-name)
				      ;; dired
				      dired-directory
				      ;; use HOME
				      "~/"))))
    (if win
	(quit-window nil win)
      (pop-to-buffer th-shell-popup-buffer nil t)
      (comint-send-string nil (concat "cd " dir "\n")))))

(global-set-key (kbd "<f12>") 'th-shell-popup)

Using that, hitting F12 will popup a *Popup Shell* buffer, initialized in the directory containing the file your are currently editing. If the current buffer is not associated with a file, then the shell’s cwd is your HOME directory.

Hitting F12 while the popup shell buffer is visible will hide it again. So you can use it as a simple toggle.

The code ensures that the same shell buffer is reused over and over again (unless you kill it), so that you don’t end up with hundredth of them.

And here’s a screenshot:

UPDATES:

• 2011-10-13 08:03: Made it work for dired buffers.
• 2012-02-24 14:41: Use quit-window instead of delete-window.

However, in contrast to Doug Hoyte’s defmacro! he introduced in Let over Lambda, my macro expanded into a normal defmacro form that expanded into a form where all args were evaluated exactly once.

Clearly, this was totally flawed, because in, say, new control structures, you may want to have some argument evaluated never.

So here’s a better version which allows for better control about evaluation. All args with trailing ! (BANG, in Clojure speak) will be evaluated exactly once, and the rest of the args stays under the programmer’s control (note that this version also takes a mandatory docstring):

(defn bang-symbol?
  "Returns true, if sym is a symbol with name ending in a exclamation
  mark (bang)."
  [sym]
  (and (symbol? sym)
       (= (last (name sym)) \!)))

(defmacro defmacro!
  "Defines a macro name with the given docstring, args, and body.
  All args ending in an exclamation mark (!, bang) will be evaluated only once
  in the expansion, even if they are unquoted at several places in body.  This
  is especially important for args whose evaluation has side-effecs or who are
  expensive to evaluate."
  [name docstring args & body]
  (let [bang-syms (filter bang-symbol? args)
        rep-map (apply hash-map
                       (mapcat (fn [s] [s `(quote ~(gensym))])
                               bang-syms))]
    `(defmacro ~name
       ~docstring
       ~args
       `(let ~~(vec (mapcat (fn [[s t]] [t s]) rep-map))
          ~(clojure.walk/postwalk-replace ~rep-map ~@body)))))

Using that, we can now easily implement the numeric if, nif, you can find in On Lisp and Let over Lambda:

(defmacro! nif
  "Numeric if: evals test! (only once) and executes either pos, zero, or neg
  depending on the result."
  [test! pos zero neg]
  `(cond
    (pos? ~test!)  ~pos
    (zero? ~test!) ~zero
    :else          ~neg))

When evaluating (nif 1 (println "pos") (println "zero") (println "neg")), now there’s only “pos” printed. With the previous defmacro! version, “pos”, “zero”, and “neg” were printed.

UPDATE: Stefan Kamphausen noticed that defmacro! doesn’t work as intended if destructuring is done in the argument list. So here’s yet another version that flattens the argument list when collecting the bang-symbols.

(defmacro defmacro!
  "Defines a macro name with the given docstring, args, and body.
  All args ending in an exclamation mark (!, bang) will be evaluated only once
  in the expansion, even if they are unquoted at several places in body.  This
  is especially important for args whose evaluation has side-effecs or who are
  expensive to evaluate."
  [name docstring args & body]
  (let [bang-syms (filter bang-symbol? (flatten args)) ;; <==
        rep-map (apply hash-map
                       (mapcat (fn [s] [s `(quote ~(gensym))])
                               bang-syms))]
    `(defmacro ~name
       ~docstring
       ~args
       `(let ~~(vec (mapcat (fn [[s t]] [t s]) rep-map))
          ~(clojure.walk/postwalk-replace ~rep-map ~@body)))))

Using that, you can define a strange nif variant that wants a vector, where the first entry is a vector containing the test, and the second entry is a vector of the pos, zero, neg entries.

(defmacro! strange-nif
  "Like nif, but with strange destructuring"
  [[[test!] [pos zero neg]]]
  `(cond
    (pos? ~test!)  ~pos
    (zero? ~test!) ~zero
    :else          ~neg))

;; Trying it...
user> (strange-nif [[1] [:pos :zero :neg]])
:pos
user> (macroexpand '(strange-nif [[1] [:pos :zero :neg]]))
(let [G__1974 1]
     (cond (pos? G__1974) :pos (zero? G__1974) :zero :else :neg))