xyzzy電卓半端移植

続き:xyzzy電卓半端移植その2 - Nosの日記,xyzzy電卓半端移植+拡張その3 (ひとまず区切り) - Nosの日記

xyzzyについてる電卓機能を移植しようとしてみたもの。こんな時期に僕はなにをやっているのだろう…。clispで半端に動く。
xyzzy電卓については→http://xyzzy.s53.xrea.com/wiki/index.php?Calc-mode%A4%CEManual
を。これとcalc-ext http://xyzzy.s53.xrea.com/wiki/index.php?tips%2Fcalc-mode%A4%CE%A5%D2%A5%B9%A5%C8%A5%EA%A1%BC を入れるとかなり使いやすい。

とりあえず下の2つを同じディレクトリに放り込んで

 $ alias calc='(cd ~/path/to/the/directory/; rlwrap clisp calc.l)'

として使うといいかもしれない。
実行すると$マークのプロンプトが出るので適当に打ち込む。

 Nos@ubuntu-colunux:~$ calc
 $

例えば

  $ 1*2+3!/4-5
 -3/2

というふうに答えが帰ってくる。Common Lispなので分数が使えますね。整数も多倍長。

  $ 100!
 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000

複素数も。

  $ I=sqrt(-1)
  #C(0 1)
  $ E^(pi*I)
  #C(-1.0d0 1.6702719951509165d-16)

カッコの中が実数部と虚数部。誤差は気にしない。*1
定数をいくつか組み込んであるがついでに単位が残念な程度に扱えるようにしてみた。例えば光速は

 $ c
 299792458 m s^-1

というような感じ。定数はunits.lの末尾に定義してある。全部(kg|m|s|C|K)の組み合わせで表示するのでだいぶ見にくいけれど適宜割り算で換算する方向で。

 $ 1 eV
 1.60217646d-19 kg m^2 s^-2
 $ 1 eV / ( 1 kB K )
 11604.50593463095d0

ただもとのxyzzy電卓にあったsetの動作をあまりチェックしていないのと、関数定義機能が動いてないのとエラーキャッチしてない(メッセージすら出さずに無視して再開する)。あとsigmaとか単位入りの量を放り込むと動いてないけど放置中。

xyzzy lispはcase sensitiveなのでそうでないcommon lispで動かそうとするといろいろシンボル名が対応取れなくなったりして面倒。もしかして
http://www.gnu.org/s/clisp/impnotes/package-case.html
このへんが使えたのかな。sbclとかでは使えないっぽいけど。

calc.l

;xyzzyに付属するcalc.lを移植しようとしてみたもの
;主な変更点(うろ覚え):
;case sensitiveなので sin -> |sin| とかした
;calc-primary-exprのcond節でlparenが捕まっていたので条件の順序を変えた
;
;calc-stringに文字列を渡すと計算する。
;infix-stringに渡すと評価直前のS式の形で返す。
;#$ に続けて計算式を打つとその行を計算式として受け取って計算する。

; 単位とか残念レベルに使えるようにしてみた。

(Defpackage :calc
  (:use :cl)
  (:export #:calc-string #:infix-string #:start-calc))

(defvar *calc-package* (find-package :calc))
(in-package :cl-user)


(load "units.l")

;; (in-package "calc")
;(provide "calc")

(defmacro while (p &rest body)
  `(loop while ,p do
	,@body))


(defconstant *calc-token-alist*
  '((#\+ . +) (#\- . -) (#\* . *) (#\/ . /) (#\% . rem) (#\= . =) (#\\ . truncate)
    (#\, . comma) (#\^ . expt) (#\! . !) (#\~ . lognot)
    (#\< (#\< . calc-lshift)) (#\> (#\> . calc-rshift))
    (#\& . logand) (#\| . logior) (#\` . logxor) (#\( . lparen) (#\) . rparen)))
(labels ((set-token-name (c s l)
	   (cond ((listp l)
		  (dolist (x l)
		    (set-token-name (car x) (cons c s) (cdr x))))
		 (s
		  (setf (get l 'calc-operator)
			(format nil "~{~A~}~A" (reverse s) (if c c ""))))
		 (t
		  (setf (get l 'calc-operator) c)))))
  (dolist (x *calc-token-alist*)
    (set-token-name (car x) nil (cdr x))))

(defvar *calc-bits* nil)
(defvar *calc-radix* 10)
(defvar *calc-unsigned* nil)
(defvar *calc-ratio* 'ratio)

(defvar *calc-token* nil)


;;;;
(setf (symbol-function 'calc::|gcd|) #'gcd)
(setf (symbol-function 'calc::|lcm|) #'lcm)
(setf (symbol-function 'calc::|exp|) #'exp)
(setf (symbol-function 'calc::|expt|) #'expt)
(setf (symbol-function 'calc::|pow|) #'expt)
(setf (symbol-function 'calc::|log|) #'log)
(setf (symbol-function 'calc::|log10|) #'(lambda (x) (log (float x 0d0) 10d0)))
(setf (symbol-function 'calc::|sqrt|) #'sqrt)
(setf (symbol-function 'calc::|isqrt|) #'isqrt)
(setf (symbol-function 'calc::|abs|) #'abs)
(setf (symbol-function 'calc::|sin|) #'sin)
(setf (symbol-function 'calc::|cos|) #'cos)
(setf (symbol-function 'calc::|tan|) #'tan)
(setf (symbol-function 'calc::|asin|) #'asin)
(setf (symbol-function 'calc::|acos|) #'acos)
(setf (symbol-function 'calc::|atan|) #'atan)
(setf (symbol-function 'calc::|atan2|) #'(lambda (y x) (atan y x)))
(setf (symbol-function 'calc::|sinh|) #'sinh)
(setf (symbol-function 'calc::|cosh|) #'cosh)
(setf (symbol-function 'calc::|tanh|) #'tanh)
(setf (symbol-function 'calc::|asinh|) #'asinh)
(setf (symbol-function 'calc::|acosh|) #'acosh)
(setf (symbol-function 'calc::|atanh|) #'atanh)
(setf (symbol-function 'calc::|floor|) #'floor)
(setf (symbol-function 'calc::|ceil|) #'ceiling)
(setf (symbol-function 'calc::|ceiling|) #'ceiling)
(setf (symbol-function 'calc::|trunc|) #'truncate)
(setf (symbol-function 'calc::|truncate|) #'truncate)
(setf (symbol-function 'calc::|round|) #'round)
(setf (symbol-function 'calc::|rem|) #'rem)
(setf (symbol-function 'calc::|mod|) #'mod)
(setf (symbol-function 'calc::|ffloor|) #'ffloor)
(setf (symbol-function 'calc::|fceiling|) #'fceiling)
(setf (symbol-function 'calc::|fceil|) #'fceiling)
(setf (symbol-function 'calc::|ftruncate|) #'ftruncate)
(setf (symbol-function 'calc::|ftrunc|) #'ftruncate)
(setf (symbol-function 'calc::|fround|) #'fround)
(setf (symbol-function 'calc::|float|) #'(lambda (x) (float x 0d0)))
(setf (symbol-function 'calc::|int|) #'truncate)
(setf (symbol-function 'calc::|ratio|) #'rationalize)
(setf (symbol-function 'calc::|complex|) #'complex)
(setf (symbol-function 'calc::|phase|) #'phase)
(setf (symbol-function 'calc::|cis|) #'cis)
(setf (symbol-function 'calc::|min|) #'min)
(setf (symbol-function 'calc::|max|) #'max)
(setf (symbol-function 'calc::|conjugate|) #'conjugate)
(setf (symbol-function 'calc::|signum|) #'signum)
(setf (symbol-function 'calc::|sign|) #'signum)
(setf (symbol-function 'calc::|realpart|) #'realpart)
(setf (symbol-function 'calc::|real|) #'realpart)
(setf (symbol-function 'calc::|imagpart|) #'imagpart)
(setf (symbol-function 'calc::|imag|) #'imagpart)
(setf (symbol-function 'calc::|numerator|) #'numerator)
(setf (symbol-function 'calc::|num|) #'numerator)
(setf (symbol-function 'calc::|denominator|) #'denominator)
(setf (symbol-function 'calc::|den|) #'denominator)
(setf (symbol-function 'calc::|ash|) #'ash)
(setf (symbol-function 'calc::|shift|) #'ash)
(setf (symbol-function 'calc::|random|) #'random)
(setf (symbol-function 'calc::|rand|) #'random)


;;;;
(defun calc::|fibonacci| (n)
  (check-type n integer)
  (cond ((not (plusp n))
	 (error 'range-error :datum n))
	((= n 1) 1)
	((= n 2) 1)
	(t
	 (do* ((f1 1 f2)
	       (f2 1 f)
	       (f (+ f1 f2) (+ f1 f2))
	       (x 3 (+ x 1)))
	     ((>= x n) f)))))

(setf (symbol-function 'calc::|fib|) #'calc::|fibonacci|)

(defun calc-fact (n)
  (check-type n integer)
  (when (minusp n)
    (error 'range-error :datum n))
  (do* ((i 1 (+ i 1))
	(r 1 (* i r)))
      ((>= i n) r)))

(setf (symbol-function 'calc::|fact|) #'calc-fact)

(defmacro calc::|sigma| (var from to sexp)
  `(do ((,var ,from (1+ ,var))
	(#1=#:sum 0))
       ((> ,var ,to) #1#)
     (setq #1# (+ #1# ,sexp))))

(setf (symbol-function 'calc-lshift) #'ash)
(defun calc-rshift (x y) (ash x (- y)))

;;

(defun calc-token-string (x)
  (or (and (symbolp x) (get x 'calc-operator)) x ""))


(defun calc-get-token (c s fn)
  (with-output-to-string (so)
    (when c
      (write-char c so))
    (loop
      (setq c (read-char s nil nil))
      (unless c
	(return))
      (unless (funcall fn c)
	(unread-char c s)
	(return))
      (write-char c so))))


(defun calc-next-token (s)
  (loop
    (let ((c (read-char s nil nil)))
      (cond ((null c)
	     (return nil))
	    ((let ((tok (assoc c *calc-token-alist*)))
	       (when tok
		 (return (loop
			   (let ((al (cdr tok)))
			     (unless (listp al)
			       (return al))
			     (setq c (read-char s nil nil))
			     (setq tok (assoc c al))
			     (unless tok
			       (setq tok (assoc nil al))
			       (cond ((null tok)
				      (if c
					  (error "Syntax error: ~c" c)
					(error "Unexpected EOL")))
				     (c
				      (unread-char c s))))))))))
	    ((or (digit-char-p c)
		 (char= c #\.))
	     (when (char= c #\0)
	       (let ((c (read-char s nil nil)))
		 (unless c
		   (return 0))
		 (let ((base (cond ((char-equal c #\x) 16)
				   ((char-equal c #\b) 2)
				   ((digit-char-p c 8)
				    (unread-char c s)
				    8)
				   (t
				    (unread-char c s)
				    nil))))
		   (when base
		     (return (parse-integer
			      (calc-get-token nil s
					      #'(lambda (c)
						  (digit-char-p c base)))
			      :radix base))))))
	     (let ((state 'leadnum)
		   (invalid-p nil))
	       (flet ((flonum (c)
			(setq state
			      (cond ((digit-char-p c)
				     (case state
				       ((leadnum trailnum expnum) state)
				       (dot 'trailnum)
				       ((expchar expsign) 'expnum)))
				    ((char= c #\.)
				     (case state
				       (leadnum 'dot)
				       (t (setq invalid-p state))))
				    ((char-equal c #\e)
				     (case state
				       ((leadnum dot trailnum) 'expchar)
				       ((expchar expsign)
					(setq invalid-p state))
				       (expnum nil)))
				    ((or (char= c #\+)
					 (char= c #\-))
				     (case state
				       ((leadnum dot trailnum expnum) nil)
				       (expchar 'expsign)
				       (t (setq invalid-p state))))
				    (t
				     (case state
				       ((leadnum dot trailnum expnum) nil)
				       (t (setq invalid-p state))))))))
		 (flonum c)
		 (let* ((tok (read-from-string (calc-get-token c s #'flonum))))
		   (when (or invalid-p (not (numberp tok)))
		     (error "Invalid format: ~a" tok))
		   (return tok)))))
;	    ((find c " \t\n\r\f"))
	    ((find c (list #\space #\tab #\newline #\return #\page)))
	    ((or (alpha-char-p c)
		 (char= c #\_))
	     (return (intern (calc-get-token c s #'(lambda (c)
	     					     (or (alphanumericp c)
	     						 (char= c #\_))))

			      *calc-package*)))

	    (t
	     (error "Syntax error: ~c" c))))))

(defmacro calc-assoc-left (name next operators)
  `(defun ,name ()
     (let ((left (,next)))
       (while (,(if (listp operators) 'member 'eq) (car *calc-token*) ',operators)
	 (setq left `(,(pop *calc-token*) ,left ,(,next))))
       left)))

(defmacro calc-assoc-right (name next operators)
  `(defun ,name ()
     (let ((left (,next)))
       (if (,(if (listp operators) 'member 'eq) (car *calc-token*) ',operators)
	   `(,(pop *calc-token*) ,left ,(,name))
	 left))))


(defun calc-expr-list ()
  (when (eq (car *calc-token*) 'rparen)
    (pop *calc-token*)
    (return-from calc-expr-list nil))
  (let ((list nil))
    (loop
      (push (calc-expr) list)
      (cond ((eq (car *calc-token*) 'comma)
	     (pop *calc-token*))
	    ((eq (car *calc-token*) 'rparen)
	     (pop *calc-token*)
	     (return (nreverse list)))
	    (t
	     (error ") expected."))))))

(defun calc-primary-expr ()
  (let ((tok (car *calc-token*)))
    (cond ((numberp tok)
	   (pop *calc-token*)
	   tok)
	  ((eq (car *calc-token*) 'lparen)
	   (pop *calc-token*)
	   (prog1
	       (calc-expr)
	     (unless (eq (pop *calc-token*) 'rparen)
	       (error ") expected."))))
	  ((and (symbolp tok)
		(eq (symbol-package tok) *calc-package*))
	   (pop *calc-token*)
	   (cond ((eq (car *calc-token*) 'lparen)
		  (pop *calc-token*)
		  `(,tok ,@(calc-expr-list)))
		 (t tok)))
	  (t (error "Primary expected: ~A" (calc-token-string tok))))))

(defun calc-postfix-expr ()
  (let ((expr (calc-primary-expr)))
    (while (eq (car *calc-token*) '!)
      (pop *calc-token*)
      (setq expr `(calc-fact ,expr)))
    expr))

(defun calc-unary-expr ()
  (if (member (car *calc-token*) '(+ - lognot))
      `(,(pop *calc-token*) ,(calc-unary-expr))
    (calc-postfix-expr)))

(calc-assoc-right calc-power-expr calc-unary-expr expt)

(defun calc-multiplicative-expr ()
  (let ((left (calc-power-expr)))
    (loop
      (let ((ope (car *calc-token*)))
	(cond ((null ope)
	       (return left))
	      ((member ope '(* / rem truncate))
	       (setq left `(,(pop *calc-token*) ,left ,(calc-power-expr))))
	      ((or (and (eq ope 'lparen)
			(not (symbolp left)))
		   (not (and (symbolp ope)
			     (get ope 'calc-operator))))
	       (setq left `(* ,left ,(calc-power-expr))))
	      (t
	       (return left)))))))

(calc-assoc-left calc-additive-expr calc-multiplicative-expr (+ -))
(calc-assoc-left calc-shift-expr calc-additive-expr (calc-lshift calc-rshift))
(calc-assoc-left calc-logand-expr calc-shift-expr logand)
(calc-assoc-left calc-logxor-expr calc-logand-expr logxor)
(calc-assoc-left calc-logior-expr calc-logxor-expr logior)

(defun calc-assign-expr ()
  (let ((left (calc-logior-expr)))
    (cond ((eq (car *calc-token*) '=)
	   (pop *calc-token*)
	   (let ((right (calc-assign-expr)))
	     (cond ((symbolp left)
		    `(setq ,left ,right))
		   ((and (listp left)
			 (symbolp (car left))
			 (eq (symbol-package (car left)) *calc-package*))
		    (dolist (x (cdr left))
		      (or (symbolp x)
			  (error "Syntax error: ~a" (calc-token-string x))))
		    (setf (symbol-function (car left)) `(lambda ,(cdr left) ,right))
		    ''function)
		   (t
		    (error "left operand must be l-value")))))
	  (t left))))

(defun calc-expr ()
  (calc-assign-expr))

(defun calc-options (args)
  (cond (args
	 (while args
	   (let ((var (pop args))
		 (val (when (eq (car args) '=)
			(pop args)
			(pop args))))
	     (cond ((eq var 'calc::|bits|)
		    (setq *calc-bits*
			  (cond ((member val '(16 32 64)) val)
				((or (null val) (eq val 'calc::|unlimit|)) nil)
				(t (error "Invalid bits: ~A" (calc-token-string val))))))
		   ((eq var 'calc::|radix|)
		    (setq *calc-radix*
			  (cond ((member val '(2 8 10 16)) val)
				((eq val 'calc::|bin|) 2)
				((eq val 'calc::|oct|) 8)
				((eq val 'calc::|dec|) 10)
				((eq val 'calc::|hex|) 16)
				(t (error "Invalid radix: ~A" (calc-token-string val))))))
		   ((eq var 'calc::|signed|)
		    (setq *calc-unsigned* nil))
		   ((eq var 'calc::|unsigned|)
		    (setq *calc-unsigned* t))
		   ((eq var 'calc::|ratio|)
		    (setq *calc-ratio*
			  (cond ((eq val 'calc::|int|) '|int|)
				((eq val 'calc::|ratio|) '|ratio|)
				((eq val 'calc::|float|) '|float|)
				((null val) *calc-ratio*)
				(t (error "Invalid ratio: ~A" (calc-token-string val))))))
		   (t
		    (error "Unknown option: ~A" (calc-token-string var))))))
	 nil)
	(t
	 (format nil "bits=~A radix=~A ~A ratio=~A"
		 (if *calc-bits* *calc-bits* '|unlimit|)
		 *calc-radix* (if *calc-unsigned* '|unsigned| '|signed|) *calc-ratio*))))

(defun calc::infix-string (string)
  (let ((*read-default-float-format* 'double-float)
	(*calc-token* (let ((token nil))
			(with-input-from-string (s string)
			  (do ((tok (calc-next-token s) (calc-next-token s)))
			      ((null tok) (nreverse token))
			    (push tok token))))))
    (if (eq (car *calc-token*) 'calc::|set|)
	(calc-options (cdr *calc-token*))
      (let ((expr (and *calc-token* (calc-expr))))
	(when *calc-token*
	  (error "unexpected ~A." (calc-token-string (car *calc-token*))))
	expr
	))))

(defun calc::calc-string (string)
  (eval (calc::with-unit-calculation% (calc::infix-string string))))

;; (defun calc::one-line-reader (stream ch n)
;;   (declare (ignore ch n))
;;   (let ((chars))
;;     (do ((curr (read-char stream)
;; 	       (read-char stream)))
;; 	((char= #\newline curr))
;;       (push curr chars))
;;     (coerce (nreverse chars) 'string)))

;; (defun calc::one-line-calculator (stream ch n)
;;   (declare (ignore ch n))
;;   (let ((chars))
;;     (do ((curr (read-char stream)
;; 	       (read-char stream)))
;; 	((char= #\newline curr))
;;       (push curr chars))
;;     (calc::calc-string (coerce (nreverse chars) 'string))))

;; (set-dispatch-macro-character #\# #\$ #'calc::one-line-calculator)

(defun calc::start-calc-quiet ()
  (if (ignore-errors
	(princ "$ ")
	(do ((str (read-line) (read-line)))
	    ((member str '("bye" "quit") :test #'equal) t)
	  (let ((result (calc::calc-string str)))
	    (when result
	      (princ result)
	      (princ #\newline)))
	  (princ "$ ")))
      (quit)
      (calc::start-calc-quiet)))

;; (defun calc::start-calc ()
;;   (princ "$ ")
;;   (do ((str (read-line) (read-line)))
;;       ((member str '("bye" "quit") :test #'equal) t)
;;     (let ((result (calc::calc-string str)))
;;       (when result
;; 	(princ result)
;; 	(princ #\newline)))
;;     (princ "$ ")))


(defun calc::start-calc-quiet-with-eval% ()
  (let ((*read-default-float-format* 'long-float))
    (labels ((read-line_ () (read-line *standard-input* nil 'eof)))
      (if (ignore-errors
	    (princ "$ ")
					;	(do ((str (read-line) (read-line)))
	    (do ((str (read-line_) (read-line_)))
		((or (member str '("bye" "quit") :test #'equal)
		     (eq str 'eof))
		 t)
	      (if
	       (equal str "eval")
	       (progn
		 (princ "eval: ")
		 (princ (eval (read-from-string (read-line_))))
		 (princ #\newline))
	       (let ((result (calc::calc-string str)))
		 (when result
					;	       (princ result)
		   (calc::print-unit result)
		   (princ #\newline))))
	      (princ "$ ")))
	  (quit)
	  (calc::start-calc-quiet-with-eval%)))))

(calc::start-calc-quiet-with-eval%)
;;(calc::start-calc-quiet)

units.l

(in-package :calc)

(defvar *fundamental-units* '(|kg| |m| |s| |C| |K|))


;;
(defun zero-dimension-list ()
  (make-list (length *fundamental-units*) :initial-element 0))

(defstruct (unit (:constructor make-unit))
;  name
  (value 1)
  (dimensions (zero-dimension-list)))

(defun dimension (fundamental-unit u)
  (nth (position fundamental-unit *fundamental-units*) (unit-dimensions u)))

(dolist (u *fundamental-units*)
  (setf (symbol-value u)
;	(make-unit :name (symbol-name u))
	(make-unit)
	)
  (setf (nth (position u *fundamental-units*) (unit-dimensions (symbol-value u))) 1))


(defun multiply-unit (&rest args)
  (let ((units   (remove-if-not #'unit-p args))
	(numbers (remove-if     #'unit-p args)))
    (if (null units)
	(apply #'* numbers)
	(make-unit :value
		   (* (apply #'* numbers) (apply  #'* (mapcar #'unit-value units)))
		   :dimensions 
		   (apply #'mapcar #'+ (mapcar #'unit-dimensions units))))))

(defun invert-unit (arg)
  (if (unit-p arg)
      (make-unit :value (/ (unit-value arg))
		 :dimensions (mapcar #'- (unit-dimensions arg)))
      (/ arg)))

(defun divide-unit (unit1 &rest units)
  (if (null units)
      (invert-unit unit1)
      (apply #'multiply-unit unit1 (mapcar #'invert-unit units))))

(defun add-unit (&rest args)
  (if (numberp (car args))
      (apply #'+ args)
      (if (null (cdr args))
	  (car args)
	  (if (eql (unit-dimensions (car args)) (unit-dimensions (cadr args)))
	      (let
		  ((next (apply #'add-unit (cdr args))))
		(make-unit :value 
			   (+ (unit-value (car args)) (unit-value next))
			   :dimensions
			   (unit-dimensions (car args))))
	      (error "dimension does't match")))))

(defun subtract-unit (&rest args)
  (if (numberp (car args))
      (apply #'- args)
      (if (null (cdr args))
	  (multiply-unit -1 (car args))
	  (if (eql (unit-dimensions (car args)) (unit-dimensions (cadr args)))
	      (let
		  ((rest (apply #'add-unit (cdr args))))
		(make-unit :value
			   (- (unit-value (car args)) (unit-value rest))
			   :dimensions
			   (unit-dimensions (car args))))
	      (error "dimension doesn't match")))))


(defun expt-unit (base power)
  (if (unit-p base)
      (make-unit :value 
		 (expt (unit-value base) power)
		 :dimensions 
		 (mapcar #'(lambda (dim) (* dim power)) (unit-dimensions base)))
      (expt base power)))

(defun sqrt-unit (base)
  (expt-unit base 1/2))

(defun print-unit (arg)
  (if (unit-p arg)
      (progn
	(princ (unit-value arg))
	(dolist (u *fundamental-units*)
	  (let
	      ((deg (nth (position u *fundamental-units*) (unit-dimensions arg))))
	    (unless (zerop deg)
	      (if (= 1 deg)
		  (format t " ~A" (symbol-name u))
		  (format t " ~A^~D" (symbol-name u) deg))))))
      (princ arg)))


(defun with-unit-calculation% (tree)
  (if tree
    (if (listp tree)
	(cons
	 (with-unit-calculation% (car tree))
	 (with-unit-calculation% (cdr tree)))
	(cond
	  ((eq tree '+) 'add-unit)
	  ((eq tree '-) 'subtract-unit)
	  ((eq tree '*) 'multiply-unit)
	  ((eq tree '/) 'divide-unit)
	  ((eq tree 'expt) 'expt-unit)
	  ((eq tree '|expt|) 'expt-unit)
	  ((eq tree 'sqrt) 'sqrt-unit)
	  ((eq tree '|sqrt|) 'sqrt-unit)
	  (t tree)))))

(defmacro with-unit-calculation (sexp)
  `(eval (with-unit-calculation% ',sexp)))

(defmacro define-unit (name definition)
  `(defvar ,name (with-unit-calculation ,definition)))

;(defmacro define-const (name value unit)


;;;;

;; mathematical constants
(define-unit |pi| pi)
(define-unit |Pi| pi)
(define-unit |E| (exp 1.0d0))

; combined units and constants

;; aux.
(define-unit |mol| 1)
(define-unit |sec| 1)
(define-unit |meter| 1)
(define-unit |rad| 1)
(define-unit |deg| (/ pi 180))

;; combined units
(define-unit |N| (* |kg| (/ |m| |s| |s|)))
(define-unit |J| (* N |m|))
(define-unit |A| (/ C |s|))
(define-unit |V| (/ J C))
(define-unit |H| (* V (/ A) |s|))
(define-unit |F| (/ C V))
(define-unit |Ohm| (/ V A))
(define-unit |W| (* J |s|))
(define-unit |Weber| (* N |m| (/ A)))
(define-unit |Tesla| (/ |Weber| |m| |m|))
(define-unit |Pa| (/ N |m| |m|))

;; scientific constants in MKSA
(define-unit |e| (* 1.60217646d-19 C))
(define-unit |c| (* 299792458 (/ |m| |s|)))
(define-unit |h| (* 6.626068d-34 (* J |s|)))
 (define-unit |hbar| (/ |h| (* 2 pi)))
(define-unit |G| (* 6.67300d-11 (* (expt |m| 3) (expt |kg| -1) (expt |s| -2))))
(define-unit |g| (* 9.80665 (/ |m| |s| |s|)))
(define-unit |kB| (* 1.3806503d-23 (/ J K)))
(define-unit |NA| (* 6.0221415d23 (/ |mol|)))

(define-unit |e0| (* 8.85418782d-12 (/ F |m|)))
(define-unit |u0| (* 4 pi 1d-7 (/ H |m|)))

(define-unit |m_e| (* 9.1093826d-31 |kg|))
(define-unit |m_p| (* 1.672621637d-27 |kg|))
(define-unit |m_n| (* 1.674927211d-27 |kg|))

(define-unit |u| (* 1.66053886d-27 |kg|)) ;atomic mass unit

;; misc.
(define-unit |eV| (* |e| V))
(define-unit |erg| (* 1d-7 J))

(define-unit |gram| (* 1/1000 |kg|))	;gは重力加速度で使ってしまった
(define-unit |ton|  (* 1000 |kg|))

(define-unit |km| (* 1000 |m|))
(define-unit |mm| (* 1/1000 |m|))
(define-unit |nm| (* 1/1000000 |m|))
(define-unit |angstrom| (* (expt 10 -10) |m|))

(define-unit |inch| (* 0.0254 |m|))
(define-unit |feet| (* 12 |inch|))
(define-unit |ft| |feet|)
(define-unit |yard| (* 36 |inch|))	(define-unit |yd| |yard|)
(define-unit |mile| (* 1760 |yard|))
(define-unit |ml| |mile|)
(define-unit |league| (* 3 |mile|))

(define-unit |barn| (* 1d-28 |m| |m|))

(define-unit |Gauss| (* 1/10000 |Tesla|))

(define-unit |atm| (* 101325 |Pa|))
(define-unit |torr| (* 101325/760 |Pa|))
(define-unit |mmHg| (* 133.3224 |Pa|))

(define-unit |ly| (* 9.46073d15 |m|))
(define-unit |AU| (* 1.49598d11 |m|))
(define-unit |pc| (* 3.08568d16 |m|))



(define-unit |Celcius| (* 273.15 K))


(define-unit |t_pl| (sqrt (/ (* |hbar| G) (expt |c| 5))))
(define-unit |l_pl| (* |c| |t_pl|))
(define-unit |m_pl| (sqrt (/ (* |hbar| |c|) G)))
;(define-unit |q_pl| (* ))
;(define-unit |T_pl| (* ))

*1: eは素電荷に使ってしまったのでEは大文字を使っている。mathematica準拠といえなくもない。