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)
+(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))
+
+(ql:quickload '("alexandria"))
+(load "infpre.lisp")
+
+(defun solve-puzzle (permutation)
+ (destructuring-bind (a b c d e f g h i) permutation
+ (let ((result (infpre:!! a + 13 * b / c + d + 12 * e - f - 11 + g * h / i - 10)))
+ (when (= result 66) (print permutation)))))
+
+(alexandria:map-permutations #'solve-puzzle '(1 2 3 4 5 6 7 8 9) :length 9)