I figured it was about time I pimped mo' Lisp on yo asses.
(defpackage turbine (:use) (:nicknames tb))
(defconstant tb::*fail* 'tb::*fail*)
(defmethod tb::fail ()
(block nil
(handler-bind ((control-error #'(lambda (&rest ignore) (return))))
(throw tb::*fail* tb::*fail*))))
(defmacro tb::fail-if (test value)
(if test value (tb::fail)))
(shadow 'with-gensyms)
(defmacro with-gensyms (syms &body body)
`(let ,(mapcar #'(lambda (sym) `(,sym (gensym))) syms)
,@body))
(defmacro defpredicate (name pred)
`(defmethod ,name (&rest args)
(if (apply #',pred args)
(car (last args))
(tb::fail))))
(defmacro tb::suspend (value &body forms)
`(values ,value
#'(lambda () ,@forms)))
(defun tb::make-generator (fn init-args)
(let ((the-fn #'(lambda () (apply fn init-args))))
#'(lambda () (if (null the-fn) (tb::fail)
(multiple-value-bind (result new-fn)
(funcall the-fn)
(setf the-fn new-fn)
result)))))
(defmacro tb::defgen (name lambda-list &body body)
`(setf (get (defun ,name ,lambda-list ,@body) 'tb::generator) t))
(setf (get 'tb::iota 'tb::generator) t)
(defun genfunp (symb)
(get symb 'tb::generator))
(defun extract-generators (form)
(let (names forms)
(labels
((addgen (name form) (setf names (cons name names)
forms (cons form forms)))
(walker (form) (cond ((not (consp form)) form)
((or (not (consp (car form)))
(not (genfunp (caar form))))
(cons (walker (car form))
(walker (cdr form))))
(t (with-gensyms (gen-name)
(addgen gen-name
`(tb::make-generator #',(caar form) ,(cdar form)))
`(,gen-name ,@(walker (cdr form))))))))
(let ((x (walker (list form))))
(values (reverse names) (reverse forms) (car x))))))
(defmacro tb::if (test then else)
(let ((block-name (gensym))
(tag (gensym)))
`(block ,block-name
(catch ',tag
(catch 'tb::*fail*
(throw ',tag ,test))
(return-from ,block-name ,else))
,then)))
(defun closure-reader (stream char)
(declare (ignore char))
`(lambda (&rest args)
(destructuring-bind (&optional _1 _2 _3 _4 _5 _6 _7 _8 _9 &rest _>) args
(let ((_ _1) (_* args))
,@(read-delimited-list #\] stream t)))))
(set-macro-character #\[ #'closure-reader nil)
(set-macro-character #\] #'(lambda (stream char) t) t)
(defmacro tb::every (subject &body body)
(with-gensyms (loop-name ever-successful result)
(multiple-value-bind (symbol-names init-forms subject) (extract-generators subject)
(let ((init-args (mapcar [(gensym)] init-forms)))
`(let ,(mapcar [`(,_1 (list ,@(third _2)))] init-args init-forms)
,(let ((init-forms (mapcar [(list (first _2) (second _2) _1)]
init-args init-forms)))
(let ((fnames (mapcar [(gensym)] init-forms)))
`(let ,(mapcar [`(,_1 ,_2)] fnames init-forms)
(let ,(mapcar [`(,_1 (funcall ,_2))] symbol-names fnames)
(let* ((,ever-successful nil)
(,result (loop named ,loop-name
do (tb::if ,subject (tb::guard (setf ,ever-successful t) ,@body) nil)
do ,(with-gensyms (block-name)
`(block ,block-name
,@(mapcar [`(tb::if (setf ,_1 (funcall ,_2))
(return-from ,block-name)
(progn (setf ,_2 ,_3)
(setf ,_1 (funcall ,_2))))]
symbol-names fnames init-forms)
(return-from ,loop-name))))))
(if ,ever-successful ,result (tb::fail))))))))))))
(import '(t nil) 'tb)
(defmacro tb::guard (&body forms)
`(catch 'tb::*fail* ,@forms))
(defmacro tb::or (&rest forms)
(with-gensyms (block-name)
`(block ,block-name
,@(mapcar #'(lambda (form) `(tb::guard (return-from ,block-name ,form)))
forms))))
(defmethod tb::identical? (x y)
(tb::fail-if (eq x y) y))
(defmethod tb::equal? (x y)
(tb::fail-if (equalp x y) y))
(import '(1- 1+ + * - / max min abs) 'tb)
(defpredicate tb::> >)
(defpredicate tb::< <)
(defpredicate tb::>= >=)
(defpredicate tb::<= <=)
(defpredicate tb::/= [(not (equalp _1 _2))])
(defpredicate tb::== equalp)
(defpredicate tb::even? [(evenp _)])
(defpredicate tb::integer? integerp)
(defmacro tb::not (form)
`(tb::if ,form (tb::fail) nil))
(defmacro tb::and (&rest args)
`(progn ,@args))
(import '(format setq) 'tb)
(import '(&optional &rest &body &key) 'tb)
(in-package tb)
(defgen iota (from to &optional (by 1))
(if (>= from to) from
(suspend from (iota (+ from by) to))))
That beautiful flower is the beginnings of the definition of a minilanguage similar in spirit to
the Icon programming language.
Predicates either
succeed, producing their last argument as a value, or
fail, producing no value and short-circuiting evaluation up to the nearest
failure guard.
Generators produce sequences of values, and the
every form repeatedly evaluates an expression until all generators are exhausted, executing the body for those iterations where the test was successful. If no tests where successful, the
every fails as a whole.
In the completed language, one would be able to do things like (if (== (one-of foo bar baz) (gen 10 20 30)) (print "One of foo, bar or baz is equal to 10, 20 or 30")), or (print "Foo appears before bar in \"" string "\" in positions: ") (every (print (> (find string "foo") (find string "bar"))) " ").
Right now, it allows for stupidly concise, although terribly inefficient (I'm no compiler writer), code like the following:
(every (setq i (iota 1 100))
(format t "~A is prime~%" i (not (every (> i (integer? (/ i (iota 1 (1- i)))) 1)))))
Roughly, it says: For every i from 1 to 100, say it's prime if there are no numbers from 1 to i - 1 by which i is divisible.
The particularly odd thing is not simply conciseness -- in the prime number case, the program could be equally concise in almost any language -- but the fact that the algorithm can be turned inside out, if that happens to suit the problem at hand: compare (every (print (> (find string "foo") (find string "bar"))) with an equivalent in your favourite programming language.
The fact that I'm able to knock up something this weird in only several hours, which interacts almost seamlessly with standard Lisp (only almost, sadly) is telling of Lisp's deep-rooted flexibility.
In summary: Lisp rox your sox.
PS. If you feel like trying it out, I only know it works in CLISP. Plus, I've only been testing it for about 4 hours. Plan accordingly.
