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-10-01

ClojureでL-99 (P14 要素を2回繰り返す)

| 13:09 | ClojureでL-99 (P14 要素を2回繰り返す) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P14 要素を2回繰り返す) - わだばLisperになる

Clojureにも畳み込み用のreduceがあります。

(defn
  #^{:doc "P14 (*) Duplicate the elements of a list."
     :test (do (test= (dupli []) [])
               (test= (dupli '(a b c c d))
                      '(a a b b c c c c d d))) }
; -----
  dupli
; -----
  ([coll]
     (reduce #(concat % (list %2 %2))
             []
             coll)))

2008-09-30

ClojureでL-99 (P12 ランレングス圧縮 その3)

| 13:13 | ClojureでL-99 (P12 ランレングス圧縮 その3) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P12 ランレングス圧縮 その3) - わだばLisperになる

packの結果を加工せずに直接作成せよという問題。

Clojureのletは分割束縛の機能があるのでリスト分解 & 合成が楽です。

(defn 
  #^{:doc "P13 (**) Run-length encoding of a list (direct solution)."
     :test (do (test= (encode-direct []) [] )
               (test= (encode-direct [1]) [1] )
               (test= (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)))) }
; -------------
  encode-direct
; -------------
  ([coll]
     (if (empty? coll)
       []
       (loop [coll (concat coll (list (gensym))),
              tem (list 1 (gensym))
              acc [] ]
         (let [[car & cdr] coll, [cnt item] tem]
           (cond (empty? coll)
                 (rest (reverse acc))
                 ;; 
                 (= car item)
                 (recur cdr (list (+ 1 cnt) car) acc)
                 ;; 
                 :else
                 (recur cdr 
                        (list 1 car)
                        (cons (if (= 1 cnt)
                                item
                                tem)
                              acc))))))))

2008-09-29

ClojureでL-99 (P12 ランレングス圧縮の伸長)

| 11:54 | ClojureでL-99 (P12 ランレングス圧縮の伸長) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P12 ランレングス圧縮の伸長) - わだばLisperになる

repeatという、アイテムの繰り返しの遅延リストを作れるので、こういうのは割と簡潔に書けます。

(defn
  #^{:doc "P12 (**) Decode a run-length encoded list."
     :test (do (test= (decode []) [])
               (test= (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))) }
; ------
  decode
; ------
  ([coll]
     (if (empty? coll)
       []
       (mapcat #(if-let [n item] (and (list? %) %)
                  (take n (repeat item))
                  (list %))
               coll))))

2008-09-28

ClojureでL-99 (P11 ランレングス圧縮 その2)

| 14:37 | ClojureでL-99 (P11 ランレングス圧縮 その2) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P11 ランレングス圧縮 その2) - わだばLisperになる

書くのを忘れてましたが、defnに:testを付けると定義した時点で:testの部分が実行されます。

ということで、適切なテストケースを付ければ、きっと便利だと思います。

ただ単にassertだけを書いたテストケースでは、最初に定義した時点で意図通り動かない場合、逆にいらっと来るかもしれません(笑)

また、lengthがないのはなんでだろうと思っていましたが、countという名前で存在していたことを発見。

うーん、確かにcountという名前も妥当ではありますが…。

length、len、size、count等、同じ機能でも方言によって色んな名前がありますね。

(defn
  #^{:doc "P11 (*) Modified run-length encoding."
     :test (do (test= (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)))
               (test= (encode-modified []) [])
               (test= (encode-modified [1]) [1]))}
; ---------------
  encode-modified
; ---------------
  ([coll]
     (if (empty? coll)
       []
       (map #(if (single? %)
               (first %)
               (list (count %) (first %)))
            (pack coll)))))

(defn single? [coll]
  (nil? (rest coll)))

2008-09-27

ClojureでL-99 (P10 ランレングス圧縮)

| 14:25 | ClojureでL-99 (P10 ランレングス圧縮) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P10 ランレングス圧縮) - わだばLisperになる

Clojureでは、lambdaは、Arcのようにfn(ファンと作者は読んでいた)と書けるので楽で良いです。

また、リーダーマクロによる更なる略記法もあって、#()でArcの[]のようなことができます。

引数は、UNIXのシェルのように%1、%2、%3...と番号で参照できます。さらに良く使う%1は、%だけでも良し。

(defn
  #^{:doc "P10 (*) Run-length encoding of a list."
     :test (do (test= (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)))
               (test= (encode []) [])) }
; ------
  encode
; ------
  ([coll]
     (if (empty? coll)
       []
       (map #(list (length %) (first %))
            (pack coll)))))

2008-09-26

ClojureでL-99 (P09 連続して現われる要素を纏める)

| 07:40 | ClojureでL-99 (P09 連続して現われる要素を纏める) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P09 連続して現われる要素を纏める) - わだばLisperになる

なんとなくコメントも付けてみました。どうやら、キーと値のペアなら何でも格納できるようなので、色々活用できるのかもしれません。

(defn
  #^{:doc "P09 (**) Pack consecutive duplicates of list elements into sublists.
If a list contains repeated elements they should be placed in separate sublists."
     :test (do (test= (pack []) [[]])
               (test= (pack [1]) [[1]])
               (test= (pack '(a a a a b c c a a d e e e e))
                      '((a a a a) (b) (c c) (a a) (d) (e e e e))))
     :comment "(pack []) => []とすべきか、(pack []) => [[]]とすべきか…"}
; ----
  pack
; ----
  [coll]
  (loop [coll coll, tem [], acc [] ]
    (let [[car & cdr] coll]
      (cond (empty? coll) 
            (reverse (cons tem acc))
            ;;
            (or (= car (first tem)) (empty? tem))
            (recur cdr (cons car tem) acc)
            ;;
            :else
            (recur cdr (list car) (cons tem acc))))))

(:comment ^#'pack)
;=> "(pack []) => []とすべきか、(pack []) => [[]]とすべきか…"

2008-09-25

ClojureでL-99 (P08 リストの圧縮)

| 04:55 | ClojureでL-99 (P08 リストの圧縮) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P08 リストの圧縮) - わだばLisperになる

今回は、letのリストの分割束縛機能を無理矢理気味に使ってみました。テストのところもなんとなくマクロに。

(defn 
  #^{:doc "P08 (**) Eliminate consecutive duplicates of list elements."
     :test (test= (compress '(a a a a b c c a a d e e e e))
                  '(a b c a d e))}
; --------
  compress [coll]
; -------- 
  (loop [coll coll, acc `[~(gensym)] ]
    (let [[head & tail] coll]
      (cond 
       (empty? coll) 
       (rest (reverse acc))
       ;; 
       (= head (first acc))
       (recur tail acc)
       ;; 
       :else 
       (recur tail (cons head acc))))))

(defmacro test= [expr val]
  `(do (assert (= ~expr ~val))))

Clojureでは、,(コンマ)ではなく、~でクオート解除になります。コンマは空白として扱われるので、変数束縛の部分等でみやすく清書するために使えます。

また、ClojureはLISP-1ということもあり、古典的なマクロでは、展開先で内部で使用している関数(マクロ)が書き換えられてしまう問題が心配されますが、これは回避してくれるとのこと。CLのように名前空間も分かれているので(CLのパッケージ的)この点でもScheme+古典的マクロより安全そうです。

(let [= list]
  (= 3 3))
;=> (3 3)

(defmacro foo [x]
  `(= ~x ~x))

(let [= list]
  (foo 3))
;=> true ; 意図した通りの動作

;; scheme (Gauche等)
(define-macro (foo x)
  `(= ,x ,x))

(let ((= list))
  (foo 3))
;=> (3 3) ; 書き換えられてしまいました。

2008-09-24

ClojureでL-99 (P07 リストの平坦化)

| 09:09 | ClojureでL-99 (P07 リストの平坦化) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P07 リストの平坦化) - わだばLisperになる

今回は、テストも付けてみることにしました。

ちょっと探したところでは、解説がみつけられなかったのですが、defnの定義のときに、#^{}という形式で、色々な属性が定義できます。

そして、定義されたものに、逆の符号^#を付ければ、属性のテーブルが呼び出せるようです。

属性のテーブルは、キーワードと値の対になっていて、キーワードは、Clojureの場合、テーブルから値を取得する関数のような動きをするので、ドキュメントならば、

(:doc ^#'flatten)

でflattenのドキュメントが取得できるという具合です。

同じく:testはテスト用の関数を取得でき、

(:test ^#'flatten)

で書いたテストを実行することができます。

なかなか便利なのですが、しかし、色々盛り込むと、関数定義がごちゃごちゃするのが、ちょっと…。

(defn  
  #^{:doc "P07 (**) Flatten a nested list structure."
     :test (assert (and (= (flatten '(1((2)(()3(()()4(((("56")))))))))
                           '(1 2 3 4 "56"))
                        (= (flatten [])
                           [])))}
; -------
  flatten 
; -------
  ([coll]
     (cond (empty? coll) []
           (coll? (first coll))
           (concat (flatten (first coll))
                   (flatten (rest coll)))
           :else (cons (first coll)
                       (flatten (rest coll))))))

2008-09-22

ClojureでL-99 (P06 回文の判定)

| 20:34 | ClojureでL-99 (P06 回文の判定) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P06 回文の判定) - わだばLisperになる

CLのような順番でドキュメントを付けることもできるようです。ただこの場合、ボディ部を括弧で囲まないと上手くSLIMEのドキュメント表示にひっかかってこないという謎。

ちなみに、Clojureは引数/ボディの書き方が複数あるようですが、どれが標準なんだろうという…。

(defn palindrome? 
  "P06 (*) Find out whether a list is a palindrome.
A palindrome can be read forward or backward; e.g. (x a m a x)."
  ([coll]
     (= (seq coll) (reverse coll))))

(palindrome? "たけやぶ")
;=> false
(palindrome? "たけやぶやけた")
;=> true
(palindrome? '[x a m a x])
;=> true

2008-09-21

ClojureでL-99 (P05 コレクションの逆転)

| 21:35 | ClojureでL-99 (P05 コレクションの逆転) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P05 コレクションの逆転) - わだばLisperになる

ドキュメントを付けてみました。他にユーザコメントとテストが付けられるようです。

;; P05 (*) Reverse a list.
(defn 
  #^{:doc "P05 (*) Reverse a list."}
  rev [coll]
  (let [str? (string? coll)]
    (loop [coll coll, acc []]
      (if (empty? coll)
        (if str?
          (apply str acc)
          acc)
        (recur (rest coll) (cons (first coll) acc))))))

(rev "foooo")
;=> "oooof"
(rev '[f o o o])
;=> (o o o f)

ClojureでL-99 (P04 リストの長さ)

| 21:35 | ClojureでL-99 (P04 リストの長さ) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P04 リストの長さ) - わだばLisperになる

lengthが標準ではないようなのですが、もしかすると無限リストの存在と関係があったりするんでしょうか。

;;P04 (*) Find the number of elements of a list.

(defn length [coll]
  (loop [coll coll, acc 0]
    (if (empty? coll)
      acc
      (recur (rest coll) (+ 1 acc)))))

(length "いろはにほ")
;=> 5
;; これでは無限リストじゃ止まらない。

ClojureでL-99 (P03 K番目の要素)

| 21:35 | ClojureでL-99 (P03 K番目の要素) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P03 K番目の要素) - わだばLisperになる

;; P03 (*) Find the K'th element of a list.

(defn element-at [coll pos]
  (loop [coll coll, pos pos]
    (if (>= 1 pos)
      (first coll)
      (recur (rest coll) (- pos 1)))))

(element-at "いろはにほ" 3)

;=> \は

2008-09-18

ClojureでL-99 (P2 最後2つのペアを返す)

| 23:55 | ClojureでL-99 (P2 最後2つのペアを返す) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P2 最後2つのペアを返す) - わだばLisperになる

今日もClojureでL-99。小さいコードをいじってると心が休まります(´▽`*)

Clojureでは、()とnilは別物で、()はempty?で検査できます。

また、(rest ())はエラーではなくて、nilが返ります。

ブール値は、trueとfalseなので、別にnilがある、ということなんですね。これはこれで便利かも。

;; P02 (*) Find the last but one box of a list.

(apply str (last-2 "こんにちは"))
;=> "ちは"

(defn last-2 [col]
  (loop [col col]
    (if (nil? (rrest col))
      col
      (recur (rest col)))))
  • CLや、Schemeと違うところ
(nil? ())
;=> false

(nil? nil)
;=> true

(rest ())
;=> nil

2008-09-17

ClojureでL-99 (P1 最後のペアを返す)

| 23:58 | ClojureでL-99 (P1 最後のペアを返す) - わだばLisperになる を含むブックマーク はてなブックマーク - ClojureでL-99 (P1 最後のペアを返す) - わだばLisperになる

最近どうも鬱々として不調なのですが、なんでだろうと内省したところ、これはどうもL-99をやってないからじゃないかという結論に達しました。

ということで、今日からリハビリの為に、ClojureでL-99を開始しようかと。

いい加減 問50以降も挑戦しないととは思いますが、P1からで…。

さっと眺めただけでも、Clojureには色々面白そうな特徴があるようです。これは面白そう。

(defn my-last [col]
  (if (empty? (rest col))
    col
    (my-last (rest col))))

;; 動作例
(my-last '(1 2 3 4))
;=> (4)
(my-last [1 2 3 4])
;=> (4)
(my-last "1234")
;=> (\4)

;; デフォルトだと末尾再帰の最適化はしてくれないそうなので、
;; 用意された構文で書く必要があるらしい。
(defn my-last [col]
  (loop [col col]
    (if (empty? (rest col))
      col
      (recur (rest col)))))
;; とか

面白いとおもったところ

  • cadr、cadddrに似た合成された関数名

first + rest => frest つまり、second

(frest [1 2 3 4])
(frest [1 2 3 4])
;=> 2
(rrest [1 2 3 4])
;=> (3 4)
  • 文字列もリストみたいに扱える
(apply str (rrest "お前誰?"))
;=> "誰?"

;; repeatは無限リストを生成し、takeで最初の10個を
;; 取得、つまり遅延リスト
(apply str \う \は (take 10 (repeat \w)))
;=> "うはwwwwwwwwww"

2008-07-15

SERIESでL-99 (P07 リストの平坦化)

| 15:56 | SERIESでL-99 (P07 リストの平坦化) - わだばLisperになる を含むブックマーク はてなブックマーク - SERIESでL-99 (P07 リストの平坦化) - わだばLisperになる

この前のエントリでは、ややこしく書いてしまいましたが、マニュアルを読んでいたら、ツリーを走査する専用の関数がありました。

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

(defun flatten (list)
  (collect (choose (scan-lists-of-lists-fringe list))))

2008-07-12

サンプルコードによるSERIES入門 (番外編)

| 16:22 | サンプルコードによるSERIES入門 (番外編) - わだばLisperになる を含むブックマーク はてなブックマーク - サンプルコードによるSERIES入門 (番外編) - わだばLisperになる

LOOP、ITERATEと来たので、SERIESでもやらないではいられません…。

インストール

(asdf-install:install :series)

一発です。

使ってみる

これもなんとなくL-99を25問目まで解いてみました。

なんとなく、iterate、mappingで、繰り返し的に、scan-fnで末尾再帰的な感覚で書ける気がしてきました。

それにつけても、SERIESで書かれたソースがあまり出回ってないので、定石な書法がいまいち分からないんですよね…。

(defpackage :l99-series
  (:use :cl :series))

(in-package :l99-series)

;; P01
(defun last-pair (list)
  (collect-last
   (scan-fn 't
            (lambda () list)
            #'cdr 
            #'atom)))

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

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

;; P02
(defun last-2-pair (list)
  (collect-last
   (scan-fn 't
            (lambda () list)
            #'cdr 
            (lambda (x) (atom (cdr 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)
  (first 
   (collect-last
    (scan-fn-inclusive 
     '(values list integer)
     (lambda () (values list 0))
     (lambda (l cnt) (values (cdr l) (1+ cnt)))
     (lambda (l cnt) (or (null l)
                         (>= cnt (1- position))))))))

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

;; P04
;; 1
(defun len (list)
  (let ((cnt 0))
    (iterate ((i (scan list)))
      (incf cnt))
    cnt))

;; 2
(defun len (list)
  (collect-last
   (scan-fn-inclusive '(values integer t)
                      (lambda () (values 0 list))
                      (lambda (cnt lst) (values (1+ cnt) (cdr lst)))
                      (lambda (cnt lst) 
                        (declare (ignore cnt))
                        (null lst)))))

(len (loop :repeat 5 :collect t))
;=> 5

;; P05
(defun rev (list)
  (collect-last
   (scan-fn-inclusive '(values list list)
                      (lambda () (values () list))
                      (lambda (ans list)
                        (values (cons (car list) ans) (cdr list)))
                      (lambda (ans list)
                        (declare (ignore ans))
                        (null list)))))

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

;; P06
(defun palindrome-p (list)
  (iterate ((org (scan list))
            (rev (scan (reverse list))))
    (unless (equal org rev)
      (return-from palindrome-p nil)))
  'T)

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

;; P07
;; 1. 普通にの繰り返しと再帰
(defun flatten (list)
  (collect-append 
   (mapping ((x (scan list )))
     (if (listp x)
         (flatten x)
         (list x)))))

;; 2. gatheringで要素を投げる系
(defun flatten (list)
  (gathering ((ans collect))
    (labels ((f (list gatherer)
               (iterate ((x (scan list)))
                 (if (listp x)
                     (f x gatherer)
                     (next-out gatherer x)))))
      (f list ans))))

;; 3. 普通にの繰り返しと再帰 その2
(defun flatten (list)
  (collect-last
   (scan-fn-inclusive
    '(values list list)
    (lambda () (values () list ))
    (lambda (acc list)
      (values (append acc
                      (if (listp (car list))
                          (flatten (car list))
                          (list (car list))))
              (cdr list)))
    (lambda (acc list)
      (declare (ignore acc))
      (endp list)))))

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

;; P08
(defun compress (list)
  (gathering((ans collect))
    (iterate ((prev (previous (scan list) (gensym) 1))
              (cur (scan list)))
      (unless (equal prev cur)
        (next-out ans cur)))))

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

;; P09
(defun pack (list)
  (gathering ((ans collect))
    (let ((list (nconc (copy-list list) (list (gensym))))
          tem)
      (iterate ((x (scan list))
                (prev (previous (scan list) (gensym) 1)))
        (unless (or (equal prev x) (null tem))
          (next-out ans tem)
          (setq tem () ))
        (push x tem)))))

(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)
  (collect
    (mapping ((x (scan (pack list))))
      `(,(length x) ,(car x)))))

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

;; P11
(defun single (list)
  (and (consp list)
       (null (cdr list))))

(defun encode-modified (list)
  (collect
    (mapping ((x (scan (pack list))))
      (if (single x)
          (car x)
          `(,(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)
  (collect-nconc
   (mapping ((x (scan list)))
     (if (atom x)
         (list x)
         (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
;; gdgd
(defun encode-direct (list)
  (let ((cnt 0)
        (prev (gensym))
        flag)
    (gathering ((ans collect))
      (iterate ((x (scan (nconc (copy-list list) (list (gensym))))))
        (if (or (equal prev x) (not flag))
            (incf cnt)
            (progn 
              (next-out ans (list cnt prev))
              (setq cnt 1)))
        (setq prev x flag 'T)))))

(encode-direct '(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))

;; P14
(defun dupli (list)
  (collect-nconc 
   (mapping ((x (scan list)))
     (list x x))))

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

;; P15
(defun repli (list times)
  (collect-nconc 
   (mapping ((x (scan list)))
     (make-list times :initial-element x))))

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

;; P16
(defun drop (list n)
  (gathering ((ans collect)) 
    (iterate ((x (scan list))
              (pos (scan-range :from 1)))
      (unless (zerop (mod pos n))
        (next-out ans x)))))

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

;; P17
(defun split (list n)
  (let ((front (gatherer #'collect)))
    (iterate ((tail (scan-sublists list))
              (pos (scan-range :from 1)))
      (if (<= pos n)
          (next-out front (car tail))
          (return-from split (list (result-of front) tail))))))

(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)
  (gathering ((ans collect))
    (iterate ((x (scan list))
              (pos (scan-range :from 1)))
      (when (<= start pos end)
        (next-out ans x)))))

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

;; P19
(defun rotate (list n)
  (let ((front (gatherer #'collect))
        (n (mod n (length list))))
    (iterate ((tail (scan-sublists list))
              (pos (scan-range :from 1)))
      (if (<= pos n)
          (next-out front (car tail))
          (return-from rotate (append tail (result-of front)))))))

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

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

;; P20
(defun remove-at (list n)
  (gathering ((ans collect))
    (iterate ((x (scan list))
              (pos (scan-range :from 1)))
      (unless (= pos n)
        (next-out ans x)))))

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

;; P21
(defun insert-at (item list n)
  (gathering ((ans collect))
    (iterate ((x (scan list))
              (pos (scan-range :from 1)))
      (when (= pos n)
        (next-out ans item))
      (next-out ans x))))

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

;; P22
(defun range (start end)
  (collect (scan-range :from start :upto end)))

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

;; P23
(defun rnd-pop (list)
  (if (null list)
      ()
      (let ((n (1+ (random (length list)))))
        (gathering ((ans collect)
                    (rem collect))
          (iterate ((x (scan list))
                    (pos (scan-range :from 1)))
                   (next-out (if (= pos n) rem ans) 
                             x))))))

(defun rnd-select (list n)
  (collect-nth (1- n) 
    (nth-value 1               
      (scan-fn '(values t t) 
               (lambda () (rnd-pop list))
               (lambda (x ans)
                 (multiple-value-bind (a b) (rnd-pop x)
                   (values a (append b ans))))))))

(rnd-select '(a b c d e f g h) 3)
;=> (D A B)

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

(lotto-select 6 50)
;=> (8 3 45 43 5 34)

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

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

2008-07-11

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

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

LOOPマクロも一段落ついた気がするので、LOOPマクロのように繰り返し処理をを便利にするマクロであるITERATEを紹介してみることにしました。

インストール

(asdf-install:install :iterate)

一発です。

良いなと思ったところ

  1. LOOPマクロを知っていれば、ちょっとマニュアルを読むくらいで書けるようになる。
  2. 外の世界の(通常のCLの)制御構文が使える。

不便だなと思ったところ

  1. ループ変数を並列に束縛できない。DOマクロで言えば、DO*しかない。回避するための仕組みもあるようですが、それを使ってもいまいち挙動が把握できない気がします。

使ってみる

どんなものか自分でもあまり良く分かっていないので、なんとなくL-99を25問目まで解いてみました。

(defpackage :l99-iter (:use :cl :iterate))
(in-package :l99-iter)

;; P01
(defun last-pair (list)
  (iter (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)
  (iter (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)
  (iter (for p :from 1)
        (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)
  (iter (for x :in list)
        (count 'T)))

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

;; P05
(defun rev (list)
  (iter (for tem :initially () :then a)
        (for a :initially (copy-list list)
               :then (prog1 (cdr a) (rplacd a b)))
        (for b :initially () :then tem)
        (when (null a) 
          (return b))))

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

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

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

;; P07
(defun flatten (list)
  (iter (for x :in list)
        (if (listp x)
            (appending (flatten x))
            (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)
  (iter (for x :in list)
        (for prev :initially (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)
  (iter (for x :in (nconc (copy-list list) (list (gensym))))
        (for prev :initially (gensym) :then x)
        (for tem :initially () :then (cons x tem))
        (unless (or (equal prev x) (null tem))
          (collect tem)
          (setq tem ()))))

(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)
  (iter (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)
  (iter (for x :in (pack list))
        (collect
            (if (= 1 (length x)) 
            (car x)
            `(,(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)
  (iter (for x :in list)
        (if (atom x)
            (collect x)
            (appending
             (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)
  (iter (for x :in (nconc (copy-list list) (list (gensym))))
        (for prev :initially (gensym) :then x)
        (for tem :initially () :then (cons x tem))
        (for cnt :initially 0 :then (1+ cnt))
        (unless (or (equal prev x) (null tem))
          (collect
              (if (= 1 cnt) 
                  prev
                  (list cnt prev)))
          (setq tem () cnt 0))))

(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)
  (iter (for x :in list)
        (nconcing (list x x))))

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

;; P15
(defun repli (list times)
  (iter (for x :in list)
        (nconcing (iter (repeat times)
                        (collect x)))))

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

;; P16
(defun drop (list n)
  (iter (for x :in list)
        (for 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)
  (iter (for x :on list)
        (for pos :from 1)
        (if (> pos n) 
            (return (list tem x))
            (collect (car x) :into tem))
        (finally (return (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)
  (iter (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)
  (iter (with n := (mod n (length list)))
        (for x :on list)
        (for pos :from 1)
        (if (> pos n) 
            (return (append x tem))
            (collect (car x) :into tem))
        (finally (return 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)
  (iter (for x :in list)
        (for 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)
  (iter (for x :in list)
        (for pos :from 1)
        (if (= pos n)
          (appending (list item x))
          (collect x))))

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

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

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

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

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

(defun rnd-select (list n)
  (flet ((choose (lst)
           (if (null lst)
               ()
               (multiple-value-list 
                (remove-at lst (1+ (random (length lst))))))))
    (iter (repeat (min n (length list)))
          (for (tem x) :initially (choose list) :then (choose tem))
          (appending x))))

(rnd-select '(a b c d e f g h) 8)
;=> (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)