xyzzy電卓半端移植その2

programming lisp

si接頭辞が使えるようにしてみた。何やってるの感強い。
例えば秒でいえばsだけ定義してあるとmsとかnsとかが定義されているかのようにふるまう。マイクロ秒はus*1。シンボルの頭1文字を抜かしたところが定義済みなら適当に10のうん乗倍するということをしている。

  • 7.2km角は何立方cmか
$ (7.2 km)^3 / cm^3
3.73248E17
  • 1gの質量エネルギーはテラジュール換算でいくらか
$ 1.0 g * c^2 / TJ
89.875517873681764
  • 1GeVは何g相当か
$ 1GeV/(g c^2)
1.782661728026788d-24

という感じ。有効数字とかは扱ってない。電卓だし。
ちなみに重力定数はg_に変わった。

前回書き忘れたけどbyeとかquitと打つと終了。Ctrl+Dでもよい。

あと単位定義と定数定義を微妙に別のマクロにした。


calc.l

; 変更なし

units.l

(in-package :calc)

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


;;

(defvar *si-prefix-alist*
  `((|y| . ,(expt 10 -24))
    (|z| . ,(expt 10 -21))
    (|a| . ,(expt 10 -18))
    (|f| . ,(expt 10 -15))
    (|p| . ,(expt 10 -12))
    (|n| . ,(expt 10 -9))
    (|u| . ,(expt 10 -6))
    (|m| . ,(expt 10 -3))
    (|c| . ,(expt 10 -2))
    (|d| . ,(expt 10 -1))
    (|K| . ,(expt 10 3))
    (|k| . ,(expt 10 3))
    (|h| . ,(expt 10 2))
    (|M| . ,(expt 10 6))
    (|G| . ,(expt 10 9))
    (|T| . ,(expt 10 12))
    (|P| . ,(expt 10 15))
    (|Z| . ,(expt 10 18))
    (|Y| . ,(expt 10 21))))		;da とか使わないよね?

(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 (equal (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 (equal (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 1+-unit (arg)
  (add-unit arg 1))

(defun 1--unit (arg)
  (subtract-unit arg 1))


(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 si-unit-to-unit (s)
  (if (not (or (numberp s) (unit-p s)))
      (if (> (length (symbol-name s)) 1)
	  (let
	      ((prefix (intern (subseq (symbol-name s) 0 1) :calc))
	       (unit (intern (subseq (symbol-name s) 1) :calc)))
	    (if (and (not (boundp s))
		     (boundp unit)
		     (assoc prefix *si-prefix-alist*))
		(multiply-unit
		 (cdr (assoc prefix *si-prefix-alist*))
		 (eval unit))
		s))
	  s)
      s))

(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)
	  ((eq tree '1+) '1+-unit)
	  ((eq tree '1-) '1--unit)
;	  (t tree)))))
	  (t (si-unit-to-unit 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 &optional (unit 1))
  `(defvar ,name (with-unit-calculation (* ,value ,unit))))


;;;;

;; mathematical constants
(define-const |pi| pi)
(define-const |Pi| pi)
(define-const |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-const |e|    1.60217646d-19 C)
(define-const |c|    299792458 (/ |m| |s|))
(define-const |h|    6.626068d-34 (* J |s|))
(define-const |hbar| (* |h| (* 2 pi)))
(define-const |G|    6.67300d-11 (* (expt |m| 3) (expt |kg| -1) (expt |s| -2)))
(define-const |g_|    9.80665 (/ |m| |s| |s|))
(define-const |kB|   1.3806503d-23 (/ J K))
(define-const |NA|   6.0221415d23 (/ |mol|))

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

(define-const |m_e|  9.1093826d-31 |kg|)
(define-const |m_p|  1.672621637d-27 |kg|)
(define-const |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 |g| (* 1/1000 |kg|))
(define-unit |gram| (* 1/1000 |kg|))
(define-unit |ton|  (* 1000 |kg|))

;; (define-unit |km| (* 1000 |m|)) ;このへんがなくても動く
;; (define-unit |cm| (* 1/100 |m|))
;; (define-unit |mm| (* 1/1000 |m|))
;; (define-unit |nm| (* 1/1000000 |m|))
(define-unit |angstrom| (* (expt 10 -10) |m|))

(define-unit |litre| (* 1/1000 (expt |m| 3)))
(define-unit |l| |litre|)
(define-unit |cc| (expt |cm| 3))

;(defun yard-pound () 
  (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|))
;  'yard-pound
;  )

(define-unit |barn| (* 100 |fm| |fm|))

(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 |minute| (* 60 |s|))
(define-unit |hour| (* 60 |minute|))
(define-unit |day| (* 60 |hour|))
(define-unit |year| (* 365.25 |day|))


(define-const |Celcius| 273.15 K)

;; plack units
(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:μが打てない環境ではuを使っていいということになっているらしい