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 |

2010-11-07

Seriesでリーダーマクロ

| 23:06 | Seriesでリーダーマクロ - わだばLisperになる を含むブックマーク はてなブックマーク - Seriesでリーダーマクロ - わだばLisperになる

リーダーマクロを書くのにSeriesを使うのも抵抗があるなあということで、実験。

Gauche風に、fooという正規表現にマッチする関数が、#/foo/と書けるようにしてみます。

CL-PPCRE:SCANに展開されて、

(#/f\\\/oo/ "f\\/oo")
;=> 0
;   5
;   #()
;   #()

上記のように動作すれば良しとします。

ということで、

(defun |#/-READER| (stream char arg)
  (declare (ignore char arg))
  (let ((g (gensym))
        (re (ppcre:regex-replace-all
             "\\\\/"
             (collect 'string
                      (choose
                       (let ((prev nil))
                         (until-if (lambda (c)
                                     (cond ((and (eql #\/ c)
                                                 (not (eql #\\ prev)))
                                            'T)
                                           (:else (setq prev c)
                                                  nil)))
                                   (scan-stream stream #'read-char)))))
             "/")))
    `(lambda (,g)
       (ppcre:scan ,re ,g))))

(set-dispatch-macro-character #\# #\/ #'|#/-READER|)

と書いてみましたが、微妙な感じに。

特に、"\\\\/"を"/"に置換しているところが悲しいですね。

それはさておき、リーダーマクロの展開ですが、

(#/f\\\/oo/ "f\\/oo")
;⇒
((LAMBDA (#:G3528) (CL-PPCRE:SCAN "f\\\\/oo" #:G3528)) "f\\/oo")

という風に展開されます。

書いていて、バックスラッシュの解釈をどうすれば良いんだったか分からなくなってきたので、テストを書いてみましたが、余計分からなくなってきました。

(defpackage :g000001-test
  (:use :cl :lisp-unit))

(in-package :g000001-test)

(do-symbols (s :g000001)
  (shadowing-import s))

(remove-all-tests :g000001-test)

(define-test |#/-READER|
  (assert-equal 
   "(LAMBDA (#:G0) (CL-PPCRE:SCAN \"Foo\" #:G0))"
   (let ((*readtable* (copy-readtable nil))
         (*gensym-counter* 0))
     (set-dispatch-macro-character #\# #\/ #'|#/-READER|)
     (write-to-string
      (read-from-string "#/Foo/"))))
  (assert-equal
   "(LAMBDA (#:G0) (CL-PPCRE:SCAN \"F/oo\" #:G0))"
   (let ((*readtable* (copy-readtable nil))
         (*gensym-counter* 0))
     (set-dispatch-macro-character #\# #\/ #'|#/-READER|)
     (write-to-string
      (read-from-string "#/F\\/oo/"))) )
  (assert-equal
   "(LAMBDA (#:G0) (CL-PPCRE:SCAN \"F\\\\\\\\/oo\" #:G0))"
   (let ((*readtable* (copy-readtable nil))
         (*gensym-counter* 0))
     (set-dispatch-macro-character #\# #\/ #'|#/-READER|)
     (write-to-string
      (read-from-string "#/F\\\\\\/oo/")))))

(run-all-tests :g000001-test)
;-> #/-READER: 3 assertions passed, 0 failed.

2010-11-05

letS*への道

| 23:28 | letS*への道 - わだばLisperになる を含むブックマーク はてなブックマーク - letS*への道 - わだばLisperになる

Seriesに先行するLetSには、letS*(レットエススター)というletを踏襲した構文があります。

このletS*の束縛部では、Series(LetSでいうsequence)を束縛することができます。

動作的には、

(defparameter *alist*
  '((A . 0) (B . 1) (C . 2) (D . 3) (E . 4) (F . 5) (G . 6) (H . 7) (I . 8)
    (J . 9) (K . 10) (L . 11) (M . 12) (N . 13) (O . 14) (P . 15) (Q . 16)
    (R . 17) (S . 18) (T . 19) (U . 20) (V . 21) (W . 22) (X . 23) (Y . 24)
    (Z . 25)))

(defun square-alist (alist)
  (letS* ((entry (Elist alist))
          (square (* (cdr entry) (cdr entry))))
    (Rlist (cons (car entry) square))))

(letS* (((key . val) (Elist (square-alist *alist*)))
        (key (symbol-name key))
        (val (format nil "~@R" (1+ val))))
  (Rlist (cons key val)))
;=> (("A" . "I") ("B" . "II") ("C" . "V") ("D" . "X") ("E" . "XVII") ("F" . "XXVI")
;    ("G" . "XXXVII") ("H" . "L") ("I" . "LXV") ("J" . "LXXXII") ("K" . "CI")
;    ("L" . "CXXII") ("M" . "CXLV") ("N" . "CLXX") ("O" . "CXCVII")
;    ("P" . "CCXXVI") ("Q" . "CCLVII") ("R" . "CCXC") ("S" . "CCCXXV")
;    ("T" . "CCCLXII") ("U" . "CDI") ("V" . "CDXLII") ("W" . "CDLXXXV")
;    ("X" . "DXXX") ("Y" . "DLXXVII") ("Z" . "DCXXVI"))

のようなことができます。

Seriesを束縛できるだけでなく、分配束縛機能もあるという優れもの。

さて、このletS*を再現してみようと思ったのですが、色々と難しいところがあります。

まず、square-alistの束縛部のsquareとentryを比べてもらうと分かるのですが、entryはSeriesを束縛していて、squareは、entryの要素にアクセスする格好になっています。

SERIES::*SERIES-IMPLICIT-MAP*を知る前は、どうやって解析したものやらと思ったのですが、これはSERIES::LETの機能にのっかれば簡単にできそうです。

加えて分配束縛機能ですが、これは、DESTRUCTURING-BINDを使えば良いだろうと思いました。

ということで、マクロを組んでいったのですが、Seriesでは、LETやMULTIPLE-VALUE-BINDは用意しているもののDESTRUCTURING-BINDは用意していない様子。

これは、SeriesがDESTRUCTURING-BINDが導入されたCLtL2より前から存在するからかもしれないと思っているのですが、それはさておき、DESTRUCTURING-BINDはLETやMULTIPLE-VALUE-BINDがあれば作れそうなので、処理系のコードを利用し、その中のLETや、MULTIPLE-VALUE-BINDをSERIES::LETや、SERIES::MULTIPLE-VALUE-BINDに書き換えて偽物を作成。

DESTRUCTURING-BINDはSeriesのコードの中では利用されていたので、衝突を回避してdestructuring-bindSという名前で導入することにしました。

そんなこんなで、letS*は

(defmacro letS* (binds &body body)
  (if (endp binds)
      `(progn ,@body)
      (let ((bind (car binds)))
        (if (consp (car bind))
            `(series::destructuring-bindS ,(car bind)
                                          ,(cadr bind)
               (letS* ,(cdr binds)
                 ,@body))
            `(series::let ((,(car bind) ,(cadr bind)))
               (letS* ,(cdr binds)
                 ,@body))))))

のように定義できました。

コードは汚いですが、

にあります。

SERIES::*SERIES-IMPLICIT-MAP*がTでないと機能しませんが、とりあえずは、良しとして、Seriesの理解が深まったら対策したいと思っています。

2010-11-03

*SERIES-IMPLICIT-MAP*の怪

| 23:30 | *SERIES-IMPLICIT-MAP*の怪 - わだばLisperになる を含むブックマーク はてなブックマーク - *SERIES-IMPLICIT-MAP*の怪 - わだばLisperになる

Seriesの先祖であるletS*では、

(defun pairwise-max (list1 list2)
  (Rlist (mapS #'max (Elist list1) (Elist list2))))

というのが、

(defun pairwise-max (list1 list2)
  (Rlist (max (Elist list1) (Elist list2))))

と書けたりします。Seriesで書くとすると、

(defun pairwise-max (list1 list2)
  (collect (#Mmax (scan list1) (scan list2))))

が、

(defun pairwise-max (list1 list2)
  (collect (max (scan list1) (scan list2))))

書けるということらしいのですが、ここで変っている点としては、SCANで生成したSeriesをSeriesを扱う関数でないMAXが受けているように見えること。

なかなか便利なような、思いっきり黒魔術のような感じなのですが、Seriesのソースの中の解説にこういうletSのような書き方ができるオプションについて解説がありました。

解説によると、

SERIES::*SERIES-IMPLICIT-MAP*

を非NILにすれば

(let* ((x (car (scan '((1) (2) (3)))))
       (y (1+ x))
       (z (collect-sum (* x y))))
  (print (list x y 4))
  (print z)
  (collect (list x (catenate #Z(a) (gensym)))))

のような書き方で、

(let* ((x (#Mcar (scan '((1) (2) (3)))))
       (y (#M1+ x))
       (z (collect-sum (#M* x y))))
  (collect-last (#Mprint (#Mlist x y (series 4))))
  (print z)
  (collect (#Mlist x (catenate #Z(a) (series (gensym))))))

と等価になるよ、とのこと。

#M等を使っていた方がなんとなくSeriesかそうでないかをソース上で意識できるので健全な気もしますが面白いです。

ちなみに上記の式は、マクロ展開すると、

(LET* ((#:OUT-35 (GENSYM)))
  (LET (#:ELEMENTS-31
        (#:LISTPTR-32 '(A))
        #:ELEMENTS-1
        (#:LISTPTR-2 '((1) (2) (3)))
        X
        Y
        #:OUT-13
        (Z 0)
        #:ITEMS-28
        (#:FLAG-29 NIL)
        #:OUT-37
        (#:LASTCONS-18 (LIST NIL))
        #:LST-19)
    (DECLARE (TYPE LIST #:LISTPTR-32)
             (TYPE LIST #:LISTPTR-2)
             (TYPE NUMBER Z)
             (TYPE BOOLEAN #:FLAG-29)
             (TYPE CONS #:LASTCONS-18)
             (TYPE LIST #:LST-19))
    (SETQ #:LST-19 #:LASTCONS-18)
    (TAGBODY
     #:LL-38
      (IF (ENDP #:LISTPTR-2)
          (GO SERIES::END))
      (SETQ #:ELEMENTS-1 (CAR #:LISTPTR-2))
      (SETQ #:LISTPTR-2 (CDR #:LISTPTR-2))
      (SETQ X (CAR #:ELEMENTS-1))
      (SETQ Y (1+ X))
      (SETQ #:OUT-13 (* X Y))
      (SETQ Z (+ Z #:OUT-13))
      (PRINT (LIST X Y 4))
      (IF #:FLAG-29
          (GO #:B-23))
      (IF (ENDP #:LISTPTR-32)
          (GO #:F-24))
      (SETQ #:ELEMENTS-31 (CAR #:LISTPTR-32))
      (SETQ #:LISTPTR-32 (CDR #:LISTPTR-32))
      (SETQ #:ITEMS-28 #:ELEMENTS-31)
      (GO #:D-21)
     #:F-24
      (SETQ #:FLAG-29 T)
     #:B-23
     NIL
      (SETQ #:ITEMS-28 #:OUT-35)
     #:D-21
      (SETQ #:OUT-37 (LIST X #:ITEMS-28))
      (SETQ #:LASTCONS-18 (SETF (CDR #:LASTCONS-18) (CONS #:OUT-37 NIL)))
      (GO #:LL-38)
     SERIES::END)
    (SETQ #:LST-19 (CDR #:LST-19))
    (PRINT Z)
    #:LST-19))

のようになってしまいます。

どうもSeriesで定義されているLETや関数などは組み合わさるとマクロ展開で別のものにごりごり変形するようですね…。

2010-11-02

Seriesを引数に取ってSeriesを返す関数

| 23:10 | Seriesを引数に取ってSeriesを返す関数 - わだばLisperになる を含むブックマーク はてなブックマーク - Seriesを引数に取ってSeriesを返す関数 - わだばLisperになる

前回のエイリアスを作ってみた時の

(COLLECT-SUM (EVECTOR #(1 2 3 4)))
Non-series to series data flow from:
(EVECTOR #(1 2 3 4))

のような警告は、どうも最適化の指定が無かったためのようです。

Seriesを引数に取ってSeriesを返す関数は、

(DECLARE (OPTIMIZABLE-SERIES-FUNCTION))

のように指定してあげると最適化指定時には最適化される様子。

OPTIMIZABLE-SERIES-FUNCTIONには整数が指定できて、多値で返すSeriesの個数を指定します(デフォルトは1で省略可能)

この指定をして

(in-package :series)

(defun Rsum (Z)
  (declare (optimizable-series-function))
  (collect-sum Z))

(defun Evector (vector)
  (declare (optimizable-series-function))
  (scan 'vector vector))

と定義したところ

(funcall #'Rsum (Evector #(1 2 3 4)))
;⇒ 10

のようにしても警告は出なくなりました。

そして、この式をマクロ展開すると、

(funcall #'Rsum (Evector #(1 2 3 4)))
;⇒
(CL:LET* (#:ELEMENTS-5
          (#:LIMIT-3 (ARRAY-TOTAL-SIZE #(1 2 3 4)))
          (#:INDEX-2 -1)
          (#:SUM-0 0))
  (DECLARE (TYPE VECTOR-INDEX+ #:LIMIT-3)
           (TYPE -VECTOR-INDEX+ #:INDEX-2)
           (TYPE NUMBER #:SUM-0))
  (TAGBODY
    #:LL-8
    (INCF #:INDEX-2)
    (LOCALLY
        (DECLARE (TYPE VECTOR-INDEX+ #:INDEX-2))
      (IF (= #:INDEX-2 #:LIMIT-3)
          (GO END))
      (SETQ #:ELEMENTS-5
            (ROW-MAJOR-AREF #(1 2 3 4) (THE VECTOR-INDEX #:INDEX-2))))
    (SETQ #:SUM-0 (+ #:SUM-0 #:ELEMENTS-5))
    (GO #:LL-8)
    END)
  #:SUM-0)

となります。

なんでFUNCALLがマクロ展開されるのか、DEFUNで定義した筈のRsumもマクロ等々、色々突っ込みどころは多いですが、とりあえずSeriesを入出力する関数(マクロ)はOPTIMIZABLE-SERIES-FUNCTIONの指定が大事らしいということは分かりました。

また、Series系関数/マクロを定義する場合、関数が良いのかマクロが良いのか悩むこともありましたが、これで悩みも解消(勝手にマクロになってるので…)

2010-11-01

Seriesの関数名が長い

| 02:55 | Seriesの関数名が長い - わだばLisperになる を含むブックマーク はてなブックマーク - Seriesの関数名が長い - わだばLisperになる

Seriesを使ってみると分かるのですが、どうも微妙にSeriesの関数名は長いのです。

(collect-sum 
 (scan-range :from 1 :upto 10))
;⇒ 55

こんな感じに、Seriesを生成→collectでリストの形で収集という流れなのですが、これが色々とネストして行くと、少しの関数名の長さが蓄積していって微妙に冗長になるのです。

このあたりをどうにかできないかなあと思っていましたが、Seriesに先行するLetSというものの関数名が良い感じに短かいのでこれを踏襲してみたらどうだろうとLetSを探りつつ試してみました。

LetSだと上記は、

(Rsum (Erange 1 10))

になります。良い感じの短さ。

Rは、Reducer、Eは、Enumeratorの略の様ですが、ぱっと見た目でも分かり易い気がします。

ということで、エイリアスを定義してみたのですが、エイリアスを使うと

(COLLECT-SUM (EVECTOR #(1 2 3 4)))
Non-series to series data flow from:
(EVECTOR #(1 2 3 4))

のような警告が出ます。エイリアスでは何かが最適化できなくなるようなのですが、この辺りにもSeriesの黒魔術をみる気がします…。

2010-10-31

マクロを書くのにもSeriesを使う

| 02:18 | マクロを書くのにもSeriesを使う - わだばLisperになる を含むブックマーク はてなブックマーク - マクロを書くのにもSeriesを使う - わだばLisperになる

マクロを書くのにSeriesを使うというのは、なんとなく抵抗があるので、まずはこういうところから馴れて行くことにしました。

ごちゃごちゃしているので有名なONCE-ONLYで実験。

(import 'fare-utils:WITH-GENSYMS)

(defmacro once-only ((&rest vars) &body body)
  (multiple-value-bind (renames temps)
                       (map-fn '(values symbol symbol)
                               (lambda (var name) 
                                 (values `(,name ,var)
                                         ``(,,var ,,name)))
                               (scan vars)
                               (map-fn 'symbol #'gensym))
    `(let ,(collect renames)
       (with-gensyms ,vars
         `(let (,,@(collect temps))
            ,,@body)))))
;; seriesのリーダーマクロを使った場合
(defmacro once-only ((&rest vars) &body body)
  (multiple-value-bind (renames temps)
                       (#2M(lambda (var name) 
                             (values `(,name ,var)
                                     ``(,,var ,,name)))
                           (scan vars)
                           (#Mgensym))
    `(let ,(collect renames)
       (with-gensyms ,vars
         `(let (,,@(collect temps))
            ,,@body)))))
;; 定義
(defmacro square (x)
  (once-only (x)
    `(* ,x ,x)))

;; 動作
(square (incf x))

;; マクロ展開
(LET ((#:G1239221 (INCF X)))
  (* #:G1239221 #:G1239221))

意外にもONCE-ONLYはすっきり書けました。試してみるもんです。

2008-09-27

seriesの結果が変

| 15:00 | seriesの結果が変 - わだばLisperになる を含むブックマーク はてなブックマーク - seriesの結果が変 - わだばLisperになる

以前から、SERIESで(subseries (series 'b 'c) 0 5)の結果が#Z(LIST B C LIST B)という風に余計なものが混ってしまうのが謎でした。

このLISTってのはなんなのか、新しい仕様なのか?等々色々考えたものの放置していましたが、quekさんの環境では、こういった現象はないとのことで、これは新しい仕様なんかではないことに気付きました(笑)

まず、自分の環境構築の方法がおかしいのかと思って色々な組み合わせで、(asdf-install:install :series)を試してみましたが変化なし。

quekさんは、cl-buildで構築しているとのことで、その辺が鍵かと思って自分もcl-buildを試してみたところ上の例でいえば、#Z(B C B C B)という風に正常な結果を得られるようになりました。

cl-buildでインストールされたもののソースを眺めてみたところ、asdf-installで入手できるソースより新しかったため、最新のソースを求めて、CVS版をインストールしてみたところ、これも正常な結果を得ることができました。

手元の環境は、SBCLですが、このような謎の現象に遭遇された場合は、CVS版の利用をお勧めしたいと思います(といっても自分はバグフィックスのログ等はちゃんと読んでませんが…(^^; )

2008-07-25

SERIESでファイル処理

| 01:15 | SERIESでファイル処理 - わだばLisperになる を含むブックマーク はてなブックマーク - SERIESでファイル処理 - わだばLisperになる

夏バテのせいなのか、鬱のせいなのか、行動する気力が全然湧いてきません(;´Д`)

しかし、何か書かなくてはいけないという強迫観念が収まらないので、2chのCL入門スレでみつけた質問に挑戦してみたいと思います(笑)

お題

CL入門スレ128さんの質問。ファイルから特定の行を抽出し、その行のみ新たにファイルへ書き出す。

no title

(use-package :series)
(series::install)

(defun kakikaki (infile outfile lines)
  (collect-file-supersede outfile
   (choose (mask (choose-if #'plusp (#M1- (scan (sort (copy-list lines) #'<)))))
           (scan-file infile #'read-line))
   #'write-line))

;; 補助マクロ(ファイルが存在する場合は上書きする: 今回の問題には本質的には関係なし)
(defmacro collect-file-supersede (file items &optional (printer #'print))
  `(progn
     (when (probe-file ,file)
       (delete-file ,file))
     (collect-file ,file ,items ,printer)))

実行

(kakikaki "/etc/passwd" "/tmp/baz" '(400 2 4 8 -1))

抜き出したい行をリストで指定します。ファイル行数の範囲を越えた指定は無視されます。

結果

$ cat /tmp/baz
daemon:x:1:1:daemon:/usr/sbin:/bin/sh
sys:x:3:3:sys:/dev:/bin/sh
lp:x:7:7:lp:/var/spool/lpd:/bin/sh

2008-07-18

SERIESでツリーマッチング

| 01:36 | SERIESでツリーマッチング - わだばLisperになる を含むブックマーク はてなブックマーク - SERIESでツリーマッチング - わだばLisperになる

独習 Scheme 三週間 Teach Yourself Scheme in Fixnum Daysでは、ジェネレータを使うことによって、2つのツリーをflattenして比較するよりも効率の良いツリーマッチングを実現しているわけなのですが、SERIESは遅延評価なので効率良く似たようなことができるだろうということで色々考えてみました。

(same-fringe? '(1 (2 3)) '((1 2) 3))
(same-fringe? '(1 (2 3)) '(1 2 3))
;=> T

(same-fringe? '(1 (2 3)) '((1 2) 3 4))
;=> nil

;; コード
(use-package :series)
(series::install) ;#Mや、#Z等のリーダーマクロを使うため

;; 1
(defun same-fringe? (tree1 tree2)
  (let ((t1 (scan-lists-of-lists-fringe tree1))
        (t2 (scan-lists-of-lists-fringe tree2)))
    (and (collect-and (#Mequal t1 t2))
         (= (collect-length t1) (collect-length t2)))))

;; 2 割と無理やりにgeneratorを使ってみたもの
(defun same-fringe? (tree1 tree2)
  (let ((t1 (scan-lists-of-lists-fringe tree1))
        (t2 (scan-lists-of-lists-fringe tree2)))
    (let ((g1 (generator t1))
          (g2 (generator t2))
          (limit (max (collect-length t1) (collect-length t2))))
      (loop :repeat limit :always (equal (next-in g1) (next-in g2))))))

1は、割と普通に書いてみました。SERIESは基本的に短い方に長さが揃えられてしまうので、長さを計っています。長さを計らなければ、無限リストにも対応できますが、今度は、(1 2 3 .....)と、(1 2 3)の場合で真が返ってしまいます。

2は、オリジナルがジェネレータ使用ということで、generatorを使ってみたのですが、いまいちです。

そもそも、collect-lengthを使ってしまった時点で駄目な気がしますが、どうやったら良いんでしょうー。

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-02-13

SERIESのドキュメント

| 11:59 | SERIESのドキュメント - わだばLisperになる を含むブックマーク はてなブックマーク - SERIESのドキュメント - わだばLisperになる

凄く有用そうなのに今一つ普及していない、SERIESパッケージ。

資料も実例のソースコードも非常に少ないというか、全然Google等でも検索に引っ掛からないのですが、みつけられるところでは、CLtL2の付録のドキュメントと、SERIESの配布物の中のs-doc.txt位でしょうか。

日本語チュートリアル的なドキュメントとしては、

があります。

あと、前にこのブログでも試したものを書いてみたりしてたのを思い出しました。

こっちは、私が書いたものなので、内容は保証できませんが…。

そんな感じなのですが、今日AI Memoを漁っていたら、作者のRichard C. Water氏の解説をみつけました。

AIメモの番号は、AIM-1082と、1083です。

1082は大体、添付のs-doc.txtと似たような内容で、1083は理論的な解説です。

SERIESは言語とは、特定の言語とは独立したものだそうで、Pascal版のSERIESも載ってたりしてます。

あと、あんまり関係ないですが、SERIESの前身のような、LetSというものも見付けました、こちらは、AIM-680aですが、なんとなくSERIESよりこっちの方が簡素で分かりやすい気がしないでもありません…。

2007-11-06

Series (3) / generatorとgatherer

| 01:34 |  Series (3) / generatorとgatherer - わだばLisperになる を含むブックマーク はてなブックマーク -  Series (3) / generatorとgatherer - わだばLisperになる

今回は、Seriesと同じく配布されていて、また同じくCLtL2の巻末にも関連して収録されている、ジェネレータとギャザラを試してみることにしました。

generator

ジェネレータは、シリーズの列を順番に取り出す機構のようです。

(generator シリーズ)

とすると、ジェネレータが生成されます。

生成された、ジェネレータは

(next-in ジェネレータ 空になったときのアクション)

で順番に取り出すことができ、空になると、指定したアクションを実行します。

(defun doとgeneratorをつかったfizzbuzz ()
  (do ((gen (generator (scan-range :from 1 :upto 100))))
      (())
    (let* ((i (next-in gen (return)))
	   (fizz (zerop (mod i 3)))
	   (buzz (zerop (mod i 5))))
      (print (cond ((and fizz buzz) "FizzBuzz")
		   (fizz "Fizz")
		   (buzz "Buzz")
		   ('T i))))))

無理矢理な感じですが、FizzBuzzを作ってみました。doは無限ループと変数束縛のために使っています。

gatherer

ギャザラはジェネレータの逆で、

(gatherer コレクタ) ;コレクタは、collect系の関数

結果を溜め込む機構であるギャザラを生成し、

(next-out ギャザラ)

で指定したギャザラに溜め込み、溜め込んだものは、

(result-of ギャザラ)

を呼ぶことで、結果として返せます。

(defun remq (item list &key (count -1))
  (let ((res (gatherer #'collect)))
    (iterate ((l (scan list)))
      (cond ((zerop count) (next-out res l))
	    ((eq item l) (decf count))
	    ('T (next-out res l))))
    (result-of res)))

(remq 'x '(x x x x x foo x) :count 2)
;=> (X X X FOO X) 

gathererを使ってeqで要素を比較するremoveを作ってみました。

gathering

gathererは出力が一つですが、gatheringは複数を切り換え出力できるところが違い、また、本体から抜けると自動で結果が返されます。

(gathering ((変数 コレクター) (変数 コレクター)) ~本体~)
(defvar hiyoko '(♂ ♀ ♂ ♀ ♂ ♀ ♂ ♀ ♂ ♀ ♂ ♂ ♀ ♂  ♂ ♀ ♂ ♀ ♀ ♂ ♀ ♀))

(gathering ((m collect) (f (lambda (x) (collect 'vector x))))
  (iterate ((i (scan hiyoko)))
    (case i
      ((next-out m i))
      ((next-out f i)))))
=>
(♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂), #(♀ ♀ ♀ ♀ ♀ ♀ ♀ ♀ ♀ ♀ ♀)

ひよこの選別をすると考えて、♂はリストで、♀はベクタの2値を返しています。

2007-11-03

Series (2)

| 22:48 |  Series (2) - わだばLisperになる を含むブックマーク はてなブックマーク -  Series (2) - わだばLisperになる

今回もSeriesがどんなものなのか色々試してみています。

実際の利用事例をGoogle Codeを使って検索してみるのですが、利用例は見当らずで、見付かるものといえばSERIES自体のソースコード位です。

CLTL2では、map-fnを#M、seriesを#Zとリードマクロ文字で定義して表記してあります。

これは、表記としても使う上でも便利だなと思うのですが、自分で定義しないといけないんだと思ってコードを検索してみたら、SERIESのソース自体に定義がありました(*'-')

(series::install)

を実行することで使えるようになるらしいです。が、#Mが自分の手元だと上手く機能しません…。何が間違っているのだろうか…。

色々試してみる

自分の予想では、SERIESはSRFI-42に非常に近い使い勝手ではないだろうか思い、SRFI-42の使用例をSERIESに翻訳してみることにしました。ちなみに自分は、SRFI-42の使い方も良く分かっているわけではありません…。

とりあえずウェブで見付けてきた題材と翻訳を列記してみます。

doukaku.org:九九の表示よりdo-ecの例
;; doukaku 
(define (display99 n)
  (do-ec (: x 1 (+ n 1)) (: y 1 (+ n 1))
         (format #t "~d * ~d = ~2d~%" x y (* x y))))
;; SERIESで
(defun display99 (n)
  (iterate ((x (scan-range :from 1 :upto n)))
    (iterate ((y (scan-range :from 1 :upto n)))
      (format t "~D * ~D = ~2D~%" x y (* x y)))))

適当なマクロですが、

(defmacro iterate* (binds &body body)
  `,(reduce (lambda (b res)
	      `(iterate (,b) ,res))
	    binds
	    :initial-value `(progn ,@body)
	    :from-end 'T))

のようにすれば、

(defun display99 (n)
  (iterate* ((x (scan-range :from 1 :upto n)) 
             (y (scan-range :from 1 :upto n)))
    (format t "~D * ~D = ~2D~%" x y (* x y))))

と書けてより近いような気もしましたが、気休めな気もします。

上記を任意の数に拡張した版
(define (displayNN n)
  (let ((w0 (string-length (number->string n)))
        (w1 (string-length (number->string (* n n)))))
    (do-ec (: x 1 (+ n 1)) (: y 1 (+ n 1))
           (format #t "~vd * ~vd = ~vd~%" w0 x w0 y w1 (* x y)))))
;; SERIESで
(defun displayNN (n)
  (let ((w0 (length (princ-to-string n)))
	(w1 (length (princ-to-string (* n n)))))
    (iterate ((x (scan-range :from 1 :upto n)))
      (iterate ((y (scan-range :from 1 :upto n)))
	(format t "~VD * ~VD = ~VD~%" w0 x w0 y w1 (* x y))))))
doukaku.org:隣り合う二項の差よりlist-ecの例
(define (diff xs) (list-ec (:parallel (: x xs) (: y (cdr xs))) (- y x)))
;; SERIESで
(defun diff (xs) 
  (collect (mapping ((x (scan xs)) (y (scan (cdr xs)))) (- y x))))
;;
(diff '(2 1 4 3 6 5 7))
;-> (-1 3 -1 3 -1 2)

SRFI-42ではデフォルトで入れ子になり:parallelを指定することにより並列になるそうですが、SERIESはデフォルトが並列で、入れ子は手作りになります。

doukaku.org:ダブル完全数よりsum-ecの例
(define (double-complete-number? n)
  (= (* n 3)
     (sum-ec (: i 1 (+ 1 n))
             (if (zero? (remainder n i)))
             i)))

(do-ec (: i 1 10001)
       (if (double-complete-number? i) (print i)))
;; SERIESで
(defun double-complete-number-p (n)
  (= (* n 3)
     (collect-sum 
      (choose
       (mapping ((i (scan-range :from 1 :upto n)))
	 (when (zerop (rem n i)) i))))))

(iterate ((i (scan-range :from 1 :upto 10000)))
  (when (double-complete-number-p i)
    (print i)))

まとめ

というようにSRFI-42をSERIESに変換してみましたが、結構何の捻りもなしに素直に変換できるようです。関数/マクロの名前の付け方にも非常に共通点が多いというのも理由の一つかもしれません。

2007-11-02

Series (1)

| 20:39 |  Series (1) - わだばLisperになる を含むブックマーク はてなブックマーク -  Series (1) - わだばLisperになる

CLTL2の巻末の付録にも載っていて非常に魅力的にも見えるseriesですが、全然使い方が分からないので、loopの解説と対照させつつ機能を散策してみることにしました。

下記のloopマクロを解説したサイトさんを参考にさせて頂きました。

こちらの方々のloopの事例を拾ってSERIESに変換してみています。

元々使い方が分ってないので、妙なところもあるんじゃないかと思います。

下準備

SERIESはasdf-install可能です。

(asdf-install:install :series)

いろいろなケースをSERIESで処理してみる

(use-package "SERIES")
リスト
(loop for i from 10 to 50 by 5 collect i)
;==> (10 15 20 25 30 35 40 45 50)

;; SERIESで
(collect (scan-range :from 10 :upto 50 :by 5))

まず、SERIESの作法としては、scan~でシリーズと呼ばれる列を生成し、collect~や、mapping、iterateでシリーズを加工するという流れのようです。

上では、scan-rangeでシリーズを作成し、collectでシリーズのアイテムを集めてリストに変換しています。

(loop for x in '(1 2 3 4) by #'cddr collect x) 

;; SERIESで
(collect
    (choose (series t nil)
	    (scan '(1 2 3 4))))
;==> (1 3) ; 一つ飛ばし

一つ飛しというのが良く分からず、chooseで選択しています。

(series t nil)で、tとnilが無限に続いたシリーズを作成し、それと、(scan '(1 2 3 4))を重ね合せることによってtの部分だけ拾っています。

(loop for x on '(1 2 3) collect x) 
;==> ((1 2 3) (2 3) (3))

;; SERIESで
(collect (scan-sublists '(1 2 3)))
(loop for x on '(1 2 3 4 5) by #'cddr collect x)
;==> ((1 2 3 4 5) (3 4 5) (5))

;; SERIESで
(collect
  (choose (series t nil)
	  (scan-sublists '(1 2 3 4 5))))
ハッシュ
;; 下準備
(defvar ht (make-hash-table))
(setf (gethash 'foo ht) 1)
(setf (gethash 'bar ht) 2)
(loop for x being the hash-keys in ht collect x)
; ==> (BAR FOO)

;; SERIESで
(collect (scan-hash ht))
(loop for x being the hash-keys in ht using (hash-value y) collect (cons x y))
;==> ((BAR . 2) (FOO . 1))

;; SERIESで
(collect
  (mapping (((k v) (scan-hash ht)))
    (cons k v)))

scan-hashはキーと値の多値を返すので、それをmappingで拾っています。

分割代入
(loop :for (a b) in '((1 2) (3 4) (5 6) (8))
      :collecting (list a b 'foo))
;==> ((1 2 FOO) (3 4 FOO) (5 6 FOO) (8 NIL FOO)) 

;; SERIESで
(collect 
  (mapping ((x (scan '((1 2) (3 4) (5 6) (8)))))
    (destructuring-bind (a &optional b) x
      (list a b 'foo))))

分割代入の機構は存在するのかどうかが分からなかったので、mappingの内部でdestructuring-bindを使用しています。

要素ごとに処理
(loop for i in '(1 2 3) do (print i))
;1
;2
;3

;; SERIESで
(iterate ((x (scan '(1 2 3))))
  (print x))

mapppingとiterateは、mapcarとmapcのような関係です。ということで、副作用が目的なので、iterateを使っています。

(loop for i on '(1 2 3) do (print i))
;(1 2 3)
;(2 3)
;(3)

;; SERIESで
(iterate ((x (scan-sublists '(1 2 3))))
  (print x))
(loop for i across #(1 2 3) do (print i))
;1
;2
;3

;; SERIESで
(iterate ((i (scan #(1 2 3))))
  (print i))

リスト、ベクタ、ストリング等は普通にscanで処理できます。

数値の範囲を処理
(loop for i from 1.0 to 3.0 by 0.5 do (print i))
;==>1.0
;   1.5 
;   2.0 
;   2.5 
;   3.0 

;; SERIESで
(iterate ((i (scan-range :from 1 :upto 3 :by 0.5)))
  (print i))
(loop for i from 3 downto 1 do (print i))
;==>3
;   2
;   1

;; SERIESで
(iterate ((i (scan-range :from 3 :by -1 :above 0)))
  (print i))

;downtoもあるようなのですが、手元の環境では上手く動かなかったため、:byにマイナスの数値を指定しています。

(loop for i from 3.0 downto 1.0 by 0.5 do (print i))
;==>3.0 
;   2.5 
;   2.0 
;   1.5 
;   1.0 

;; SERIESで
(iterate ((i (scan-range :from 3 :by -0.5 :above 0.5)))
  (print i))
> (loop for i from 1 to 3 for x = (* i i) do (print x))
;==>1
;   4
;   9

;; SERIESで
(iterate ((i (scan-range :from 1 :upto 3)))
  (let ((x (* i i)))
    (print x)))

iterateのボディで普通に計算してみています。seriesを加工するという手もあるのかもしれません。

フィルタリング
(loop for i from 1 to 3 when (oddp i) collect i)
;==> (1 3)

;; SERIESで
(collect
  (choose 
   (mapping ((i (scan-range :from 1 :upto 3)))
     (when (oddp i)
       i))))
  • scan-rangeで1~3のシリーズを作成
  • mappingは節の最後に評価された値を集める(#Z(1 nil 3)のようになる。)
  • chooseでシリーズからnilのアイテムを捨てる
  • collectでリストに変換

もっと短く書く方法があるに違いないですが、とりあえず…。

まとめ

以上、まだまだシリーズの一部なのですが、独自の作法はあるもののseriesは、なかなか便利な気がします。

Common Lispの標準に取り込まれることも検討されていたらしいですが、もし取り込まれていたらまた面白い展開があったような気がします。さらに巨大化しちゃいますが…。

今後もまたシリーズで処理できる例題を探して変換してみたいと思います。