yamasushi:Lisp

yamasushi:Lisp

ちょっとまえにCommon Lispをいじくっていたときの記事から、いくつかひろってみます。
いまは、まったくCommon Lispとか触っていないので、自分で書いたコードでないような感覚におそわれています。 -“common lisp” - Archive - yamasushiの日記
http://yamasushi.hatenablog.com/archive/category/common%20lisp

ちょっと平均をとる

http://yamasushi.hatenablog.com/entry/20100604/1275612315

「ああ、この2つの幾何平均をとってみる」みたいな使い方をする

(defmacro mean-of (op &rest items)
  (let ((num (length items)))
   (when (> num 0)
     (case op
       ((*)  `(expt (* ,@items) ,(/ 1 num) ) )
       ((+)  `(/    (+ ,@items) ,num))
       (t (error "unknown op for mean : ~a" op))
       )))
  )

こんな感じ

(mean-of * ratio-amean-r ratio-vec ) ;; 幾何平均
(mean-of + ratio-amean-r ratio-vec ) ;; 算術平均

関数の合併

http://yamasushi.hatenablog.com/entry/20100530/1275200022

複数の関数を合体させたいから作った。

(defmacro fn-merge (&rest funs)
  (with-gensym (arg)
    `(lambda (&rest ,arg)
       (or ,@(mapcar #'(lambda (x)
                        `(apply ,x ,arg ))
                    funs)))))

定数関数

http://yamasushi.hatenablog.com/entry/20100530/1275200023

どんな引数で呼んでも定数を返す関数。

(defun fn-const (const)
  #'(lambda (&rest rest)
     (declare (ignore rest))
     const))

pairをどう実装するか

http://yamasushi.hatenablog.com/entry/20100527/1274910177

haskellのpairはlispではどう実装するか? cons cellでいいような気もするが、それだとnilを要素にしたときpprintがおかしくなる。 とりあえず、listでお茶をにごす。

(defun pair (l r)
  (list l r))

(defun fst (p)
  (car p))

(defun snd (p)
  (cadr p))

;; pair ---- (x y)
(defmacro let-pair ( (x y) pair-arg &body body )
  (with-gensym (pair)
   `(let* ((,pair ,pair-arg )
           (,x    (car  ,pair))
           (,y    (cadr ,pair)))
      ,@body
      )))

let-pairはpairにアクセスするための便法。なかなか便利。
複雑なデータ構造よりもpairのような超シンプルなものの扱いが大切な気がする。

複素数

http://yamasushi.hatenablog.com/entry/20100527/1275612697

pairの親戚の複素数。

(defmacro let-complex ( (x y) comp-arg &body body )
  (with-gensym (comp)
   `(let* ((,comp ,comp-arg )
           (,x    (realpart ,comp))
           (,y    (imagpart ,comp)))
      ,@body
      )))

zip,unzip

http://yamasushi.hatenablog.com/entry/20100527/1274910561

pairが決ったらzipが決まる

(defun zip-with (op l r)
  (cond
    ((and (listp l) (listp r))
     (mapcar op l r))
    ((vectorp l)
     (zip-with op (vector->list l) r))
    ((vectorp r)
     (zip-with op l (vector->list r)))
    (t (error "cannot zip"))
    ))

(defun zip (l r)
  (zip-with #'pair l r))

(defun unzip (z)
  (loop for item in z
       collecting (fst item) into l
       collecting (snd item) into r
       finally (return (pair l r))))

string,vector,listを一つの関数でまかなうのは、何か間違っている気がする。
いい考えが浮んだら直す。

vector->listは

(defun vector->list (v)
  (let ((len (length v)))
        (loop for i from 0 below len
           collecting (elt v i       ) into l
           collecting (elt v (- len i 1) ) into rl
           finally (return (values l rl len)))))

逆順リストと要素数も返す贅沢使用です。
リストにした後だと、逆順や要素数算定はコストがかかりそうなので。

alistから変数自動生成

http://yamasushi.hatenablog.com/entry/20100526/1274844854

  • alistのkeyと同じ変数名を自動宣言
    (defun lookup-alist (key alist)
      (let ((lookup (assoc key alist)))
        (if lookup
            (cdr lookup)
            (error "unknown key ~a~%" key))
        ))
    
    (defmacro let-alist ( (&rest keys) alist-arg &body body )
      (with-gensym (alist)
        (let ((bind-list
              (mapcar
               #'(lambda (key)
                   `(,key
                     (lookup-alist ,(intern (symbol-name key) 'keyword) ,alist)) )
               keys ) ))
        `(let* ((,alist ,alist-arg)
                ,@bind-list) 
           ;; end of bind
           ,@body ))))
    
  • 使用例 こんな感じのalistを参照する
    ((:ds-sym            . :sg-puppy)
    (:initial-pts-maker . "MAKE-RANDOM-PT-INSIDE-UNIT-CIRCLE" )
    (:canvas-size       . (:width 1200 :height 1200) )
    (:paint-op          . "PAINT-CIRCLE")
    ;;
    (:gray-ratio        . 1)
    (:alpha-ratio       . 1)
    (:radius-ratio      . 10)
    (:gray-scheme       . "KUDARI-PARABOLA")
    (:alpha-scheme      . "KUDARI-PARABOLA")
    (:radius-scheme     . "KUDARI-PARABOLA")
     ;;
    (:num-traj          . 200 )
    (:num-pt            . 500 )
    (:num-pt-for-test   . 500 )
    )
    
    (defun make-dynsys-for-painter ( param )
      (let-alist (initial-pts-maker
                  num-traj
                  ds-sym
                  num-pt
                  num-pt-for-test
                  ) param
          (let* ((ds-param      (lookup-alist ds-sym dynsys:*dynsys-param-alist*))
                 (initial-pts   (series:collect (funcall (intern initial-pts-maker :dynsys)
                                                         num-traj)) )
                 (ds-serieses   (make-dynsys-series-multi
                                 (getf ds-param :dynform)
                                 :trans (getf ds-param :trans) 
                                 :init  initial-pts ) )
                 )
            (values
             (series:subseries ds-serieses 1 (1+ num-pt)          ) 
             (series:subseries ds-serieses 1 (1+ num-pt-for-test) )) 
            )))
    

haskellの関数をつくってみる

http://yamasushi.hatenablog.com/entry/20100523/1274612609

  • haskellと言えばfold
    (defun foldl (op ini lst)
      (reduce op lst
              :initial-value ini))
    
    (defun foldr (op ini lst)
      (reduce op lst
              :initial-value ini
              :from-end t))
    
  • drop & take
    (defun drop(n s)
      (subseq s n))
    
    (defun take (n s)
      (subseq s 0 n ))
    
  • filter
    (defun filter (pred lst)
      (remove-if-not pred lst))
    
  • split-atは改善の余地がある。
    (defun split-at (n lst)
      (cond
        ((null lst) (pair '() '()))
        (t
         (let ((result-car '()))
           (do* ((last-xs lst       xs)
                 (x       (car lst) (car last-xs))
                 (xs      (cdr lst) (cdr last-xs))
                 (i 1     (1+  i)))
                ((or (> i n) (null x))
                 (pair (nreverse result-car) last-xs))
             (push x result-car)
             ;(format t "~a , ~a , ~a , ~a~%" i x xs result-car)
             )))))
    
    (defun split-at-string (n str)
      (cond
        ((<= n 0) (pair "" str))
        ((<= (length str) 0) (pair "" ""))
        (t
         (pair (subseq str 0 n)
               (subseq str n)))))
    
    (defun split-at-vector (n vec)
      (cond
        ((<= n 0) (pair #() vec))
        ((<= (length vec) 0) (pair #() #()))
        (t
         (pair (subseq vec 0 n)
               (subseq vec n)))))
    

->,->>マクロ

WikiBooksEn:Clojure Programming/Concepts

3. Programmers new to Lisp are often put off by the "inside-out" reading of forms like the date creation above. Starting from the inside, you

  • get a new Random
  • get the next random integer
  • cast it to a long
  • pass the long to the Date constructor

You don't have to write inside-out code in Clojure. The -> macro takes its first form, and passes it as the first argument to its next form. The result then becomes the first argument of the next form, and so on. It is easier to read than to describe:

 1    (-> (Random.) (.nextInt) (long) (Date.))
 2  -> #<Date Sun Dec 21 12:47:20 EST 1969>

http://yamasushi.hatenablog.com/entry/20100523/1274610393

;; (fn-compose f g h)
;; ---> (lambda (x) (-> x f g h ))
;;      = (lambda (x) (h (g (f x))))
(defmacro fn-composite (&rest fns)
  (with-gensym (x)
    `(lambda (,x) (-> ,x ,@fns))))
(defmacro -> (x form &rest more)
  (if more
      `(-> (-> ,x ,form) ,@more )
      (if (listp form)
          `(,(car form) ,x ,@(cdr form))
          `(,form ,x))))

(defmacro ->> (x form &rest more)
  (if more
      `(->> (->> ,x ,form) ,@more )
      (if (listp form)
          `(,(car form) ,@(cdr form) ,x)
          `(,form ,x))))
(defmacro lambda-pipe ( x &body pipeline )
  (with-gensym (pipe-arg)
    `(->> ,x
          ,@(mapcar #'(lambda (p)
                        (destructuring-bind ((&rest arg) &body body) p
                          ;(format t "( ~a ) ~a~%" arg body) 
                          (if (singletonp arg)
                              `( (lambda (,@arg)
                                   ,@body) )
                              `( (lambda (,pipe-arg)
                                   (destructuring-bind (,@arg) ,pipe-arg
                                                        ,@body ) )))))
                    pipeline))))

with-gensymはシンボル生成マクロ(practial common lispのアレ)
singletonpは

(defun singletonp (x)
  (cond
    ( (atom x) nil )
    ( (and (listp x) (car x) (not (cdr x))) T)
    ( t (= (length x) 1))))
More ...