with-hq9+

with-hq9+.lisp

(in-package :cl-user)

(defpackage :HQ9+
  (:use #:cl)
  (:shadow #:+)				; for avoiding package lock!!
  (:export
   #:HQ9+
   #:with-HQ9+))

(in-package :HQ9+)

(defun H ()
  (princ "Hello, World!"))

(defun |9| ()
  (loop with btlfmt = "~[~1@*~:[n~;N~]~1@*o more~:;~:*~A~]~:* bottle~[s~;~:;s~] of beer"
     for i from 99 downto 0
     do (format t "~? on the wall, ~?.~%"
		btlfmt `(,i t) btlfmt `(,i nil))
       (format t "~[Go to the store and buy some more,~:;Take one down and pass it around,~] ~? on the wall.~2%"
	       i btlfmt `(,(if (zerop i) 99 (1- i)) t))))

(defun HQ9+ (string &optional (accumulator 0))
  (flet
      ((Q () (princ string))
       (+ () (incf accumulator)))
    (loop for c across string
       do (ecase c
	    (#\H (H))
	    (#\Q (Q))
	    (#\9 (|9|))
	    (#\+ (+))))
    accumulator))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun hq9+-symbol-p (symbol)
    (loop for c across (symbol-name symbol)
	    always (member c '(#\H #\Q #\9 #\+))))

  (defun explode (symbol &optional package)
    (loop for c across (symbol-name symbol)
       collect (intern (string c) package))))

#+ignore
(defmacro with-HQ9+ ((&optional (accumulator (gensym))) &body body)
  `(let ((,accumulator 0))
     (declare (ignorable ,accumulator))
     (flet
	 ((Q () (format t "~{~A~^ ~}" ',body))
	  (+ () (incf ,accumulator)))
       ,@(loop for form in body
	    if (and (symbolp form)
		    (hq9+-symbol-p form))
	    append
	      (loop for s in (explode form :HQ9+) ; for conversion like cl:loop.
		 collect `(,s))
	    else
	    collect form))))

#+ignore
(defmacro with-HQ9+ ((&optional (accumulator (gensym))) &body body)
  `(let ((,accumulator 0))
     (declare (ignorable ,accumulator))
     (flet
	 ((Q () (format t "~{~A~^ ~}" ',body))
	  (+ () (incf ,accumulator)))
       (symbol-macrolet ((H (H))
			 (Q (Q))
			 (|9| (|9|))
			 (+ (+)))
	 ,@(loop for form in body
	      if (and (symbolp form)
		      (hq9+-symbol-p form))
	      append (explode form :HQ9+) ; for conversion like cl:loop.
	      else
	      collect form)))))

#+ignore
(defmacro with-HQ9+ ((&key (accumulator (gensym)) (H 'H) (Q 'Q) (|9| '|9|) (+ '+))
		     &body body)
  (flet ((find-hq9+-form (c)
	   ;; TODO: flet `symbol-char-0' here?
	   (cond ((char= c (char (symbol-name H) 0)) `(,H))
		 ((char= c (char (symbol-name Q) 0)) `(,Q))
		 ((char= c (char (symbol-name |9|) 0)) `(,|9|))
		 ((char= c (char (symbol-name +) 0)) `(,+)))))
    `(let ((,accumulator 0))
       (declare (ignorable ,accumulator))
       (flet
	   ((,H () (H))
	    (,Q () (format t "~{~A~^ ~}" ',body))
	    (,|9| () (|9|))
	    (,+ () (incf ,accumulator)))
	 (symbol-macrolet ((,H (,H))
			   (,Q (,Q))
			   (,|9| (,|9|))
			   (,+ (,+)))
	   ,@(loop for form in body
		if (and (symbolp form)
			(every #'find-hq9+-form (symbol-name form)))
		append
		  (loop for c across (symbol-name form)
		     collect
		       #+nil (ecase c
			       (#\H `(,H))
			       (#\Q `(,Q))
			       (#\9 `(|9|))
			       (#\+ `(+)))
		       (find-hq9+-form c))
		else
		collect form))))))

(defmacro with-HQ9+ ((&key (accumulator (gensym)) (H 'H) (Q 'Q) (|9| '|9|) (+ '+))
		     &body body)
  (let ((HQ9+-table
	 (flet ((symbol-char-0 (symbol)
		  (char (symbol-name symbol) 0)))
	   `((,(symbol-char-0 H) . ,H)
	     (,(symbol-char-0 Q) . ,Q)
	     (,(symbol-char-0 |9|) . ,|9|)
	     (,(symbol-char-0 +) . ,+)))))
    (flet ((find-hq9+-form (c)
	     (cdr (assoc c HQ9+-table))))
      `(let ((,accumulator 0))
	 (declare (ignorable ,accumulator))
	 (flet
	     ((,H () (H))
	      (,Q () (format t "~{~A~^ ~}" ',body))
	      (,|9| () (|9|))
	      (,+ () (incf ,accumulator)))
	   (symbol-macrolet ((,H (,H))
			     (,Q (,Q))
			     (,|9| (,|9|))
			     (,+ (,+)))
	     ,@(loop for form in body
		  if (and (symbolp form)
			  (every #'find-hq9+-form (symbol-name form)))
		  append
		    (loop for c across (symbol-name form)
		       collect (find-hq9+-form c))
		  else
		  collect form)))))))

#|
CL-USER> (hQ9+:with-HQ9+ (:accumulator acc)
	   H
	   + + +
	   (list acc)
	   )
Hello, World!
(3)


;;; explode '[HQ9+]*' symbol
CL-USER> (hQ9+:with-HQ9+ (:accumulator acc)
	   HHQ+HQ++
	   acc)
Hello, World!Hello, World!HHQ+HQ++ ACCHello, World!HHQ+HQ++ ACC
3

;;; (TODO: This impl does not walks internal forms. (I need a kind of code walker..) ;)
;;; talk symbols to bind
CL-USER> (hQ9+:with-HQ9+ (:accumulator acc :H H)
	   + + +
	   (list H acc)
	   )
Hello, World!
("Hello, World!" 3)


CL-USER> (hQ9+:with-HQ9+ (:accumulator acc :H P :+ @)
	   @ @ @
	   (list P acc @))
Hello, World!
("Hello, World!" 3 4)
|#