## ~duncan-bayne/viet-cl

12a7fa611365ac86eed2a2e854f3fdc0cdf21228 — Duncan Bayne 8 years ago
```Initial attempt at solving problem idiomatically
```
```2 files changed, 151 insertions(+), 0 deletions(-)

A infpre.lisp
A viet-cl.lisp
```
`A infpre.lisp => infpre.lisp +139 -0`
```@@ 0,0 1,139 @@
+;;;; Common Lisp infix/prefix conversion utility
+;;;
+;;;  \$Id: infpre.lisp,v 1.2 2006/11/19 16:01:52 jornv Exp \$
+;;;
+;;;; Licence LGPL
+;;;
+;;;; Copyright: Joern Inge Vestgaarden (jivestgarden at gmail com)
+;;;
+;;;; Syntax:
+;;;   Works directly on lisp lists, not on strings.
+;;;   The cost is that all operators must be separated by spaces,
+;;;   i.e. 1 + 2, not 1+2.
+;;;
+;;;   Unlike most infix utilities, the infix conversion
+;;;   does not interpret +,*, etc. as binary operators,
+;;;   but as list separted by the operator
+;;;   i.e. (1 + 2 + 3) -> (+ 1 2 3) not (+ (+ 1 2) 3).
+;;;
+;;;   The order of the operators determine precedence.
+;;;
+;;;; Examples:
+;;;   (1 + 2 * exp (-1 * x) * 3) -> (+ 1 (* 2 (exp (* -1 x)) 3))
+;;;
+;;;; Bugs:
+;;;   Works directly on CL symbols which cause problems with packages.
+;;;   The math macro only works because +-*/ are speical variables
+;;;   in the common-lisp package. In general a new test-function
+;;;   working on names must be made and supplied.
+;;;
+
+
+(defpackage "INFPRE"
+  (:use "COMMON-LISP")
+  (:export "INFIX->PREFIX"
+	   "PREFIX->INFIX"
+	   "MATH"
+	   "!!")
+  (:documentation ""))
+
+(in-package :infpre)
+
+(defvar *separators* (list '+ '- '* '/) "Default operators for the math macro")
+
+(defun remove-brackets (lst)
+  "Reduses lists with just one item to the item itself"
+  (do ((result lst (car result)))
+      ((or (not (consp result))
+	   (not (null (cdr result)))) result)))
+
+(defun separate-list (lst separator test)
+  "Returns list of sub-sequences defined by separator"
+  (if (not (consp lst))
+      lst
+      (let ((result (cons separator nil)) (end 0) (sub)
+	    (lst (if (funcall test (car lst) separator)
+		     (cdr lst)
+		     lst)))
+	(do () ((null lst) result)
+	  (setf end
+		(position separator lst :test test))
+	  (setf sub
+		(cons (subseq lst 0 end) nil))
+	  (setf result
+		(append result sub))
+	  (setf lst
+		(if end
+		    (nthcdr (+ 1 end) lst)
+		    nil)))
+	(setf (cdr result) (mapcar #'remove-brackets (cdr result)))
+	result)))
+
+(defun separate-tree (lst separator test)
+  "Apply separate-list on all sublists"
+  (if (or (not (consp lst)) (eql (first lst) 'quote))
+      lst
+      (progn
+	(setf lst (mapcar #'(lambda (x)
+			      (if (not (consp x))
+				  x
+				  (separate-tree x separator test)))
+			  lst))
+	(if (not (find separator (rest lst)))
+	    lst
+	    (separate-list lst separator test)))))
+
+(defun infix->prefix (infix-expr separators &key (test #'eql))
+  "Converts an infix expression to prefix"
+  (let ((result infix-expr))
+    (dolist (sep separators)
+      (setf result (separate-tree result sep test)))
+    (remove-brackets result)))
+
+(defun insert-between (lst sep)
+  (if (or (not (consp lst))
+	  (not (rest lst)))
+      lst
+    (cons (first lst) (mapcan #'(lambda (x) (list sep x)) (rest lst)))))
+
+(defun prefix->infix (prefix-expr separators &key (test #'eql))
+  "Converts a prefix expression to infix"
+  (let ((in-expr (mapcar #'(lambda (x)
+			     (remove-brackets (if (listp x)
+					      (prefix->infix x separators)
+					    x)))
+			 prefix-expr)))
+    (if (or (not (listp in-expr))
+	    (not (member (first in-expr) separators :test test)))
+	in-expr
+      (insert-between (rest in-expr) (first in-expr)))))
+
+
+;;;; End of infix prefix conversion
+
+
+;;;; Additional usefull macros as interfaces to infix->prefix
+
+(defmacro !! (&body body)
+  "Converts infix to prefix"
+  (infix->prefix body *separators*))
+
+(defmacro math (name args  &body body)
+  "Similar to defun, only with infix math. If name is _ then make a lambda expression"
+  (let* ((body2 (if (stringp (car body))
+		    (infix->prefix (cdr body) *separators*)
+		    (infix->prefix body *separators*)))
+	 (doc    (if (stringp (car body))
+		     (car body)
+		     "Math function")))
+    (if (eql name '_)
+	(compile nil (list 'lambda args body2))
+	(list 'defun name args doc body2))))
+
+
+
+
+
+
+
+

```
`A viet-cl.lisp => viet-cl.lisp +12 -0`
```@@ 0,0 1,12 @@
+(require :sb-posix)