(defvar *dot-program* "/usr/bin/dot")
(defvar *counter* 0)
(defvar *node-to-label* nil)

(defun quotep (x) (and (not (listp x)) (not (stringp x))))

(defun string-to-symbol (s)
  (multiple-value-bind (a)
      (read-from-string (string s))
    a))

(defun child-atoms-to-list (nodes)
  (let ((root (car nodes))
	(children (cdr nodes)))
    (cons root
	  (mapcar (lambda (c) (if (not (listp c))
				  (list c)
				  (child-atoms-to-list c)))
		  children))))

(defun p-n-write (tmp-file-name output-file-name nodes)
  (with-open-file (*standard-output* tmp-file-name
				     :direction :output 
				     :if-exists :supersede 
				     :if-does-not-exist :create)
    (format t "digraph G {~%")
    (p-n nodes)
    (format t "} ~%"))
  (run-program *dot-program* (list "-Grankdir=LR" "-Gcharset=latin-1" "-Tps" tmp-file-name "-o" output-file-name) :wait t))

(defun p-n (nodes)
    (if (eql '() nodes)
	'()
	(progn (process-node (car nodes) (cdr nodes))
	       (mapcar #'p-n (cdr nodes)))))

(defun enum-node (node)
  (cond ((stringp node) (progn   (setf *counter* (+ 1 *counter*))
				 (let ((nodename (concatenate 'string "NODE" (write-to-string *counter*))))
				   (setf (gethash nodename *node-to-label*) node)
				   nodename)))
	((quotep node) (string-to-symbol (enum-node (string node))))))

(defun do-enum-nodes (nodes)
  (setf *node-to-label* (make-hash-table :test #'equal))
  (setf *counter* 0)
  (enum-nodes (child-atoms-to-list nodes)))

(defun enum-nodes (node)
  (cond ((null node) '())
	((listp node)
	 (cons (enum-nodes (car node))
	       (enum-nodes (cdr node))))
	(t (enum-node node))))

(defun process-node (node children)
  (loop for child in children
     do (format t "~a -> ~a; ~%" node (car child)))
  (let* ((lbl
					;(remove-if #'digit-char-p (string node))
	  (string (gethash (string node) *node-to-label*))
	   )
	 (shape (if (quotep node)
		    "box"
		    "ellipse"))
	 (label (if (quotep node)
		    (concatenate 'string "<" (string-downcase lbl) ">")
		    lbl)))
    (format t "~a [label=\"~a\", shape=~a]; ~%" node label shape)
    ))

(defun mk-fromlist (liste)
  (if (null liste) '()
      (remove-if #'null (list 'fromlist (list 'relation (list (car liste))) (mk-fromlist (cdr liste))))))

(defun attr-eql (a b)
  (list (list 'attribute (list a))
	(list "=")
	(list 'attribute (list b))))

(defun mk-cond-and (liste)
  (let* ((har-neste (not (null (cdr liste))))
	 (resultat (cons 'condition (car liste))))
    (if har-neste
	(append (list 'condition resultat) (list (list "AND") (mk-cond-and (cdr liste))))
	resultat)))

(defun demo-query ()
  (p-n-write "tmp.dot" "graph.ps"
	     (do-enum-nodes `(query
			      (sfw "SELECT"
				   (sellist (attribute "a"))
				   "FROM"
				   ,(mk-fromlist (list "Kunde" "Ordre" "Ordrelinje" "Varegruppetilhorlighet"))
				   "WHERE"
				   ,(mk-cond-and (list (attr-eql "Kunde.KundeID" "Ordre.KundeID")
						       (attr-eql "Ordre.OrdreID" "Ordrelinje.OrdreID")
						       (attr-eql "Ordrelinje.VareID" "Varegruppetilhorlighet.VareID")
						       '((attribute "Kunde.ftype") "=" (pattern "'E'"))
						       '((attribute "Varegruppetilhorlighet.Varegr") "=" (pattern "'GaffelTrucker'"))
						       '((attribute "OrdreDate") "LIKE" (pattern "'2008%'")))))))))