Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2008-07-06

サンプルコードによるLOOPマクロ入門 (番外編 L-99)

| 15:25 | サンプルコードによるLOOPマクロ入門 (番外編 L-99) - わだばLisperになる を含むブックマーク はてなブックマーク - サンプルコードによるLOOPマクロ入門 (番外編 L-99) - わだばLisperになる

機能を順に紹介して行くのも良いのですが、実際に手を動かしてみるのも良いだろうということで、意味なくL-99のP25まで、無理にLOOPを使って解いてみました。

「できるだけLOOPマクロ内で完結させる」ということをテーマに書いてみました。

自分はLOOPマクロは苦手でしたが、それでも200行位LOOPばっかり書けば、いい加減馴れて来るようです…。

;; P01
(defun last-pair (list)
  (loop :for x :on list :when (atom (cdr x)) :return x))

(last-pair '(1 2 3 4))
;=> (4)

(last-pair '(1 2 3 . 4))
;=> (3 . 4)

;; P02
(defun last-2-pair (list)
  (loop :for x :on list :when (atom (cddr x)) :return x))

(last-2-pair '(1 2 3 4))
;=> (3 4)

(last-2-pair '(1 2 3 . 4))
;=> (2 3 . 4)

;; P03
(defun element-at (list position)
  (loop :for p := 1 :then (1+ p)
        :for x :in list
        :when (= position p) :return x))

(element-at '(a b c d e) 13)
;=> NIL

(element-at '(a b c d e) 3)
;=> C

;; P04
(defun len (list)
  (loop :for x :in list :count 'T))

(len '(1 2 3 4))
;=> 4

;; P05
(defun rev (list)
  (loop :for a := (copy-list list) :then (prog1 (cdr a) (rplacd a b))
        :and b := ()               :then a
        :when (null a) :return b))

(rev '(1 2 3 4))
;=> (4 3 2 1)

;; P06
(defun palindrome-p (list)
  (loop :for nom :in list
        :and rev :in (reverse list)
        :always (equal nom rev)))     

(palindrome-p '(1 2 3 2 1))
;=> T

;; P07
(defun flatten (list)
  (loop :for x :in list 
        :if (listp x)
          :append (flatten x)
        :else
          :collect x))

(flatten '(1 2 3 (4 5 (6 (7 (8 (9 (((10((((((()))))))))))))))))
;=> (1 2 3 4 5 6 7 8 9 10)

;; P08
(defun compress (list)
  (loop :for x    :in list
        :and prev := (gensym) :then x
        :unless (equal prev x) :collect x))

(compress '(a a a a b c c a a d e e e e))
;=> (A B C A D E)

;; P09
(defun pack (list)
  (loop :for x    :in (nconc (copy-list list) (list (gensym)))
        :and prev := (gensym) :then x
        :and tem  := ()       :then (cons x tem)
        :unless (or (equal prev x) (null tem))
          :collect tem
          :and :do (setq tem () )
        :end))

(pack '(a a a a b c c a a d e e e e e))
;=> ((A A A A) (B) (C C) (A A) (D) (E E E E E))

;; P10
(defun encode (list)
  (loop :for x :in (pack list)
        :collect `(,(length x) ,(car x))))

(encode '(a a a a b c c a a d e e e e))
;=> ((4 A) (1 B) (2 C) (2 A) (1 D) (4 E))

;; P11
(defun encode-modified (list)
  (loop :for x :in (pack list)
        :when (= 1 (length x)) 
          :collect (car x)
        :else
          :collect `(,(length x) ,(car x))))

(encode-modified '(a a a a b c c a a d e e e e))
;=> ((4 A) B (2 C) (2 A) D (4 E))

;; P12
(defun decode (list)
  (loop :for x :in list 
        :when (atom x)
          :collect x
        :else
          :append (make-list (first x) 
                             :initial-element (second x))))

(decode '((4 A) B (2 C) (2 A) D (4 E)))
;=> (A A A A B C C A A D E E E E)

;; P13
(defun encode-direct (list)
  (loop :for x    :in (nconc (copy-list list) (list (gensym)))
        :and prev := (gensym) :then x
        :and tem  := ()       :then (cons x tem)
        :and cnt  := 0        :then (1+ cnt)
        :unless (or (equal prev x) (null tem))
          :when (= 1 cnt) 
            :collect prev 
          :else 
            :collect (list cnt prev)
          :end
          :and :do (setq tem () cnt 0)
        :end))

(encode-direct '(a a a a b c c a a d e e e e))
;=> ((4 A) B (2 C) (2 A) D (4 E))

;; P14 (*) Duplicate the elements of a list.
(defun dupli (list)
  (loop :for x :in list :nconc (list x x)))

(dupli '(a b c c d))
;=> (A A B B C C C C D D)

;; P15
(defun repli (list times)
  (loop :for x :in list 
        :nconc (loop :repeat times :collect x)))

(repli '(a b c) 3)
;=> (A A A B B B C C C)

;; P16
(defun drop (list n)
  (loop :for x :in list
        :and pos :from 1
        :unless (zerop (mod pos n)) :collect x))

(drop '(a b c d e f g h i k) 3)
;=> (A B D E G H K)

;; P17
(defun split (list n)
  (loop :for x :on list
        :for pos :from 1
        :when (> pos n) 
          :do (return-from split (list tem x))
        :else
          :collect (car x) :into tem)
        :end
        :finally (return-from split (list list () )))

(split '(a b c d e f g h i k) 3)
;=> ((A B C) (D E F G H I K))

;; P18
(defun slice (list start end)
  (loop :for x :in list
        :for pos :from 1
        :when (<= start pos end) 
          :collect x :into res
        :finally (return res)))

(slice '(a b c d e f g h i k) 3 7)
;=> (C D E F G)

;; P19 
(defun rotate (list n)
  (loop :with n := (mod n (length list))
        :for x :on list
        :for pos :from 1
        :when (> pos n) 
          :do (return-from rotate (append x tem))
        :else
          :collect (car x) :into tem)
        :end
        :finally (return-from rotate list))

(rotate '(a b c d e f g h) 3)
;=> (D E F G H A B C)

;; P20
(defun remove-at (list n)
  (loop :for x :in list
        :and pos :from 1
        :unless (= pos n) :collect x))

(remove-at '(a b c d) 2)
;=> (A C D)

;; P21
(defun insert-at (item list n)
  (loop :for x :in list
        :and pos :from 1
        :when (= pos n)
          :append (list item x)
        :else 
          :collect x))

(insert-at 'alfa '(a b c d) 2)
;=> (A ALFA B C D)

;; P22
(defun range (start end)
  (loop :for i :from start :to end :collect i))

(range 4 9)
;=> (4 5 6 7 8 9)

;; P23
(defun remove-at (list n)
  "取り除く要素/残りの多値を返すバージョン"
  (loop :for x :in list
        :and pos :from 1
        :unless (= pos n) 
          :collect x :into res
        :else 
          :collect x :into item
        :finally (return-from remove-at (values res item))))

(remove-at '(1 2 3 4) 4)
;=> (1 2 3),(4)

(defun rnd-select (list n)
  (flet ((choose (lst)
           (multiple-value-list 
            (remove-at lst (1+ (random (length lst)))))))
    (loop :for i :from 1 :to (min n (length list))
          :for (tem x) := (choose list) :then (choose tem)
          :append x)))

(rnd-select '(a b c d e f g h) 7)
;=> (H E G F D B C)

;; P24
(defun lotto-select (n range)
  (rnd-select (range 1 range) n))

(lotto-select 6 49)
;=> (14 37 4 8 9 46)

;; P25
(defun rnd-permu (list)
  (rnd-select list (length list)))

(rnd-permu '(a b c d e f))
;=> (A C B F D E)

サンプルコードによるLOOPマクロ入門 (6)

| 07:52 | サンプルコードによるLOOPマクロ入門 (6) - わだばLisperになる を含むブックマーク はてなブックマーク - サンプルコードによるLOOPマクロ入門 (6) - わだばLisperになる

ローカル変数

LOOP内ではループ内でローカル変数を宣言して使用することができます。

良く

(let ((foo 1)
      (bar 2)
      (baz 3))
  (loop :repeat 5 :collect (list foo bar baz)))

;=> ((1 2 3) (1 2 3) (1 2 3) (1 2 3) (1 2 3))

のようなコードを見かけますが、これは、

(loop :with foo := 1 :and bar := 2 :and baz := 3
      :repeat 5 :collect (list foo bar baz)))

;=> ((1 2 3) (1 2 3) (1 2 3) (1 2 3) (1 2 3))

という風に:withを使って書けます。

上の元の例の場合、foo、bar、bazはletを使って並列に束縛されているのですが、この場合、:andでつなぎます。

では、

(let* ((foo 1) 
       (bar 2)
       (baz (* 3 foo)))
  (loop :repeat 5 :collect (list foo bar baz))))

;=> ((1 2 3) (1 2 3) (1 2 3) (1 2 3) (1 2 3))

のようにlet*で順番に上から束縛する場合はどう書くかというと、

(loop :with foo := 1 :and bar := 2
      :with baz := (* 3 foo)
      :repeat 5 :collect (list foo bar baz))

;=> ((1 2 3) (1 2 3) (1 2 3) (1 2 3) (1 2 3))

と:withを複数回使って書きます。

LOOPでは、:andが文脈によって意味が変ってくるのですが、どっちがパラレルでどっちがシリアル束縛か忘れてしまったら、マクロ展開をして結果を確認するのがてっとり早いかもしれません。

まとめ

という風にLOOPマクロ内で変数宣言もできるのですが、複雑になると若干読み難くくなるところもあるかもしれません…。

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20080706