Lispy Days

趣味で Lisp な日々 (index) (weblog) (view) (edit) (help)

;; menu

;; recent changes

サンプルコード集

append

再帰しないやつ．

再帰しないやつ．ちょっとエラー処理が足りないけど，効率は良いと思う． 

(setq ptr (setf (cdr ptr) (cons (car p) nil)))
== (setq ptr (cdr (rplacd ptr (cons (car p) nil))))

あたりが厄介かなぁ．（↑が正しいかどうかはまだ未確認） 終了判定に null を使っているのが問題なので atom で判定して null じゃなかったら エラーとか変更の必要すれば良いはず．cons しなければ nconc に変更も可能． 

(defun my-append (&rest lsts)
  ;; 頭の nil をとばす
  (do ((l lsts (cdr l)))
      ((or (null lsts) (not (null (car l)))) (setq lsts l)))
  ;; 先頭が atom のみだったらそれを返す
  (when (atom (car lsts))
    (if (null (cdr lsts))
        (return-from my-append (car lsts))
        (error "~S is not a list." (car lsts))))
  ;; 先頭となる result と cons したセルを指す ptr を準備
  (let* ((result (cons (caar lsts) nil))
         (ptr    result))
    ;; 先頭のリストを cons する．このとき ptr はリストの末尾のセルを指す
    (do ((p (cdar lsts) (cdr p)))
        ((null p))
      (setq ptr (setf (cdr ptr) (cons (car p) nil))))
    ;; 末尾のリスト以外をコピー（末尾のリストは ptr で指すだけ）
    (do ((l (cdr lsts) (cdr l)))
        ((null (cdr l))
         (setq ptr (setf (cdr ptr) (car l)))
         result)
      ;; 個々の lst の複製リスト
      (do ((p (car l) (cdr p)))
          ((null p))
        (setq ptr (setf (cdr ptr) (cons (car p) nil)))))))

mapcar

再帰しないやつばっかりです。

お手軽に

まず lst = (cons lst1 lsts) でリストをまとめた後、 %map を使って関数の引数 (%map #'car lst) と 残り (map #'cdr lst) に分解しつつ処理を進める．効率は良くない。 引数と残りのリストを別々に作成するために それぞれリストを走査し，さらに collect で cons が発生するからです。 

(defun my-mapcar-1 (fn lst1 &rest lsts)
  (flet ((%map (fn lst) (loop for e in lst collect (funcall fn e))))
    (loop with lst = (cons lst1 lsts)
          while (not (some #'null lst))
          collect (apply fn (%map #'car lst))
          do (setq lst (%map #'cdr lst)))))

ちょっと効率を考えて

関数の引数と残りを一度に分解するために do を使っている。 (別に LOOP でもいいんだけど趣味の問題) (caar l) ←引数になる要素を arg-list に push して、 残り（cdar）の部分を setf で書き換えている。 関数の引数は lst の個数と同じだとわかっているので 毎回 push して GC に任せるのはちょっと無駄。

(some #'null lst) を (loop for e in lst when (null e) return t) に しているのは手元の処理系では後者のほうが効率がよかったから。 インタプリタな処理系(CLISPとか)では (some #'null lst) のほうが良い かもしれません。 

(defun my-mapcar-2 (fn lst &rest lsts)
  (do* ((lst (cons lst lsts))
        (args-list nil nil)
        (acc nil))
       ((loop for x in lst when (null x) return t) (nreverse acc))
    (do ((l lst (cdr l))
         (a args-list (cdr a)))
        ((null l) (push (apply fn (nreverse args-list)) acc))
      (push (caar l) args-list)
      (setf (car l) (cdar l)))))

効率を考えて

あらかじめ args-list に使うリストを構築しておき、それを

setf で書換えて使う事により cons の回数を減らしている。 
(defun my-mapcar-3 (fn lst &rest lsts)
  (do* ((lst (cons lst lsts))
        (args-list (copy-list lst))
        (acc nil))
       ((loop for x in lst when (null x) return t) (nreverse acc))
    (do ((l lst (cdr l))
         (a args-list (cdr a)))
        ((null l) (push (apply fn args-list) acc))
      (setf (car a) (caar l))
      (setf (car l) (cdar l)))))

Y Combinator

関数名を使わずに再帰。(funcall f) で関数がでてくるようになってるのがミソ。 lambda 内での再帰は (funcall (funcall f) 引数) で関数名を使わず再帰できる。 ↓の例だと (funcall *fib* 20) で 6765 が得られるハズ。 

(defun Y (f)
  ((lambda (x) (funcall f (lambda () (funcall x x))))
   (lambda (x) (funcall f (lambda () (funcall x x))))))

(defparameter *fib*
  (Y (lambda (f)
       (lambda (n)
     (if (< n 2)
         n
       (+ (funcall (funcall f) (- n 1))
          (funcall (funcall f) (- n 2))))))))

FFI を用いた IEEE 浮動小数点とビット列との相互変換 

#include <stdio.h>
int float_to_bits (float f) { return *((int*)&f); }
int double_to_bits_hi (double f) { return ((int*)&f)[0];}
int double_to_bits_lo (double f) { return ((int*)&f)[1]; }
float bits_to_float (int i) { return *((float*)&i); }
double bits_to_double (int hi, int lo) { int v[2]; v[0] = hi; v[1] = lo; return *((double*)v); }

上記の float.c をコンパイルして float.so を準備する。 

gcc -Wall -shared -o float.so float.c

あとは FFI を用いて関数を呼ぶだけです。 

* (bits->float (float->bits 3.1415926))
3.1415925
* (multiple-value-bind (h l) (double->bits 3.1415926d0) (bits->double h l))
3.1415926d0

この float->bits, bits->float, double->bits, bits->double という関数を定義する例を以下に示します．

GNU CLISP 

(ffi:def-call-out float->bits
  (:name "float_to_bits")
  (:library "./float.so")
  (:arguments (f ffi:single-float))
  (:return-type ffi:int)
  (:language :stdc))

(ffi:def-call-out bits->float
  (:name "bits_to_float")
  (:library "./float.so")
  (:arguments (i ffi:int))
  (:return-type ffi:single-float)
  (:language :stdc))

(ffi:def-call-out double->hi-bits
  (:name "double_to_bits_hi")
  (:library "./float.so")
  (:arguments (f ffi:double-float))
  (:return-type ffi:int)
  (:language :stdc))

(ffi:def-call-out double->lo-bits
  (:name "double_to_bits_lo")
  (:library "./float.so")
  (:arguments (f ffi:double-float))
  (:return-type ffi:int)
  (:language :stdc))

(defun double->bits (f) (values (double->hi-bits f) (double->lo-bits f)))

(ffi:def-call-out bits->double
  (:name "bits_to_double")
  (:library "./float.so")
  (:arguments (hi ffi:int) (lo ffi:int))
  (:return-type ffi:double-float)
  (:language :stdc))

CMU Common Lisp 

(ext:load-foreign "./float.so" :verbose t)
(defun float->bits (f)
  (alien:alien-funcall (alien:extern-alien "float_to_bits" (function c-call:int single-float)) f))
(defun bits->float (i)
  (alien:alien-funcall (alien:extern-alien "bits_to_float" (function single-float c-call:int)) i))
(alien:def-alien-routine "double_to_bits_hi" c-call:int (f double-float :in))
(alien:def-alien-routine "double_to_bits_lo" c-call:int (f double-float :in))
(defun double->bits (f)
  (values
  (alien:alien-funcall (alien:extern-alien "double_to_bits_hi" (function c-call:int double-float)) f)
  (alien:alien-funcall (alien:extern-alien "double_to_bits_lo" (function c-call:int double-float)) f)))
(defun bits->double (hi lo)
  (alien:alien-funcall
   (alien:extern-alien "bits_to_double" (function double-float c-call:int c-call:int))
   hi lo))

;; def-alien-routine を使うスタイルもある
;; (alien:def-alien-routine "bits_to_double" double-float (hi c-call:int :in) (lo c-call:int :in))
;; (defun bits->double (hi lo)
;;   (bits-to-double hi lo))

UFFI 

(uffi:load-foreign-library "./float.so")
(uffi:def-function ("float_to_bits" float->bits) ((f :float)) :returning :int)
(uffi:def-function ("bits_to_float" bits->float) ((i :int)) :returning :float)
(uffi:def-function ("double_to_bits_hi" %double->bits/hi) ((f :double)) :returning :int)
(uffi:def-function ("double_to_bits_lo" %double->bits/lo) ((f :double)) :returning :int)
(defun double->bits (f) (values (%double->bits/hi f) (%double->bits/lo f)))
(uffi:def-function ("bits_to_double" bits->double) ((hi :int) (lo :int)) :returning :double)

足し算

Common Lisp で暗算の練習 

(defun adder (&aux x y)
  (flet ((Question ()
       (setq x (1+ (random 100))
         y (1+ (random 100)))
       (format t "~&Q. ~A * ~A = ?~%" x y))
     (Answer ()
       (format t "~&> ")
       (force-output)
       (let ((input (read)))
         (cond ((not (numberp input))
            (format t "~&Bye....~%")
            :end)
           ((= (* x y) input)
            (format t "~&Good!~%"))
           (t
            (format t "~&Humm... ~A is correct.~%" (* x y)))))))
    (loop
     (Question)
     (when (eq (Answer) :end) (return)))))

CMUCL の MP パッケージを使って 10 秒制限を付ける例。 MP パッケージについては CMUCL の注意点を参照の事。 

(defun adder* (&aux x y)
  (flet ((Question ()
       (setq x (1+ (random 100))
         y (1+ (random 100)))
       (format t "~&Q. ~A * ~A = ?~%" x y))
     (Answer ()
       (mp:with-timeout (10 (format t "~&TIME OVER!! ANSWER : ~A~%" (* x y)) nil)
         (format t "~&> ")
         (force-output)
         (let ((input (read)))
           (cond ((not (numberp input))
              (format t "~&Bye....~%")
              :end)
             ((= (* x y) input)
              (format t "~&Good!~%"))
             (t
              (format t "~&Humm... ~A is correct.~%" (* x y))))))))
    (loop
     (Question)
     (when (eq (Answer) :end) (return)))))

XML 

<?xml version="1.0" encoding="UTF-8" ?>
<OAI-PMH xmlns="http://www.openarchives.org/OAI/2.0/" 
         xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
         xsi:schemaLocation="http://www.openarchives.org/OAI/2.0/
         http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd">
 <responseDate>2002-05-01T19:20:30Z</responseDate>
 <request verb="GetRecord" identifier="oai:arXiv:hep-th/9901001"
          metadataPrefix="oai_dc">http://an.oa.org/OAI-script</request> 
 <GetRecord>
   <record>...</record>
 </GetRecord> 
</OAI-PMH>

のような samle.xml を用意したときの例。

xmls

xmls-1.0 の例。 xml を 

(タグ 属性のリスト 子要素*)

という形式のリストに変換する。また、この形式のリストを xml に変換する事も可能。 

(defun read-file (file)
  (with-open-file (s file :direction :input)
    (let ((str (make-string (file-length s))))
      (read-sequence str s)
      str)))

(defun xmls-example-1 ()
  (let ((str (read-file "sample.xml")))
    (xmls:parse str)))

で 

(("OAI-PMH" . "http://www.openarchives.org/OAI/2.0/")
 (("schemaLocation" "http://www.openarchives.org/OAI/2.0/
         http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd"))
 (("responseDate" . "http://www.openarchives.org/OAI/2.0/") nil
  "2002-05-01T19:20:30Z")
 (("request" . "http://www.openarchives.org/OAI/2.0/")
  (("metadataPrefix" "oai_dc") ("identifier" "oai:arXiv:hep-th/9901001")
   ("verb" "GetRecord"))
  "http://an.oa.org/OAI-script")
 (("GetRecord" . "http://www.openarchives.org/OAI/2.0/") nil
  (("record" . "http://www.openarchives.org/OAI/2.0/") nil "...")))

このリストを xmls:toxml 関数で xml に変換できる。

cllib

cllib の xml ライブラリの例。 ツリー構造になった xml オブジェクトを返す。 xml-obj 型のオブジェクトに対して xmlo-nm, xmlo-args, xmlo-data を用いてタグ名、属性、子要素を取り出す。 

CL-USER> (setq xml (cllib:xml-read-from-file "sample.xml" :out nil))
(#<cllib::xml-decl xml [version="1.0" encoding="UTF-8"] {482FC4E5}>
 #<cllib:xml-obj
   #<xml-namespace "http://www.openarchives.org/OAI/2.0/" "ns4345" 5
     {4828137D}>:OAI-PMH [#<xml-namespace
                            "http://www.w3.org/2001/XMLSchema-instance" "ns4346" 1
                            {48282475}>:schemaLocation="http://www.openarchives.org/OAI/2.0/
         http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd"] 14/7 objects 56/229 chars
   {482FC75D}>)
CL-USER> (cllib:xmlo-nm (second xml))
"OAI-PMH"
CL-USER> (cllib:xmlo-args (second xml))
((#<xml-namespace "http://www.w3.org/2001/XMLSchema-instance" "ns4346" 1
    {48282475}>:schemaLocation
  "http://www.openarchives.org/OAI/2.0/
         http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd"))
CL-USER> (cllib:xmlo-data (second xml))
(" "
 #<cllib:xml-obj
   #<xml-namespace "http://www.openarchives.org/OAI/2.0/" "ns4345" 5
     {4828137D}>:responseDate [] 2/1 object 20/25 chars
   {482FC80D}>
 " "
 #<cllib:xml-obj
   #<xml-namespace "http://www.openarchives.org/OAI/2.0/" "ns4345" 5
     {4828137D}>:request [:verb:="GetRecord" 
:identifier:="oai:arXiv:hep-th/9901001" :metadataPrefix:="oai_dc"] 2/1 object 27/83 chars
   {482FCC65}>
 " "
 #<cllib:xml-obj
   #<xml-namespace "http://www.openarchives.org/OAI/2.0/" "ns4345" 5
     {4828137D}>:GetRecord [] 5/3 objects 5/15 chars
   {482FD045}>
 " ")
CL-USER> (defun to-sexp (obj)
  (flet ((parse-attribute (lst)
       (list (cllib:xmln-ln (first lst)) (second lst))))
    (cond ((cllib:xml-obj-p obj)
       `(,(cons (cllib:xmlo-nm obj) (cllib:xmlns-uri (cllib:xmln-ns (cllib:xmlo-name obj))))
         ,(mapcar #'parse-attribute (cllib:xmlo-args obj))
         ,@(mapcar #'to-sexp
               (remove " " (cllib:xmlo-data obj) :test #'equal))))
      (t obj))))
CL-USER> (to-sexp (second xml))
(("OAI-PMH" . "http://www.openarchives.org/OAI/2.0/")
 (("schemaLocation" "http://www.openarchives.org/OAI/2.0/
         http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd"))
 (("responseDate" . "http://www.openarchives.org/OAI/2.0/") nil
  "2002-05-01T19:20:30Z")

 (("request" . "http://www.openarchives.org/OAI/2.0/")
  (("verb" "GetRecord") ("identifier" "oai:arXiv:hep-th/9901001")
   ("metadataPrefix" "oai_dc"))
  "http://an.oa.org/OAI-script")
 (("GetRecord" . "http://www.openarchives.org/OAI/2.0/") nil
  (("record" . "http://www.openarchives.org/OAI/2.0/") nil "...")))

外部プログラムにパースしてもらう

http://www.pmsf.de/resources/lisp/expat.html のように外部プログラムを使ってパースする。 element.c は 

((タグ 属性*) 子要素)

という形式なので startElement 関数をいじって 

/* Handle Element start and stop tags */
void startElement(void *userData, const char *name, const char **atts)
{
  const char** att;
  int attr=0;
  finishText((int*)userData);
  fputs("(\"",stdout);
  outputString(name);
  putchar('"');
  for (att=atts;*att;att+=2)
    {
      if (att==atts) {
        attr=1;
        fputs("(", stdout);
      }
      fputs(" (\"",stdout);
      outputString(*att);
      fputs("\" \"",stdout);
      outputString(*(att+1));
      fputs("\")",stdout);
    }
  if (attr==1)
    fputs(") ",stdout);
  else
    fputs("nil",stdout);
}

とすれば xmls 等と似た 

(タグ 属性のリスト 子要素)

という形式になる。後は 8bit を通すように outputText 関数も変更する。

Last Update: 09:31:16 2004/11/03 (GMT+9)

Powered by cl-wiki on CLISP/CMUCL

Copyright © 2004 lambda_list@hotmail.com. All Rights Reserved.