[Common Lisp] 素数

(loop for l = (loop for i from 2 to 100000 collect i)
        then (delete-if {zerop (mod _ x)} (cdr l))
      for x = (car l)
      while x
      collect x)

『数学ガール/フェルマーの最終定理』の記念に

NLISP - A Numerical Common Lisp with Array Syntaxと思ったが、よく分からない。

ま、とりあえずなんか描けたからよしとしよう。

;; cd /tmp
;; svn co https://nlisp.svn.sourceforge.net/svnroot/nlisp/trunk nlisp

(pushnew "/tmp/nlisp/" asdf:*central-registry*)

(require :nlisp)

(use-package :nlisp)

(let ((x (.rseq 0 100 50)))
  (plot (.sin x) (.cos x)))

もうやってられない

そういうときもあるのさ。

[本] 今月は素敵な月

『実践 Common Lisp』 が発売になった。素晴しい。『Smalltalkで学ぶオブジェクト指向プログラミングの本質』 も発売になった。もうすこしすると 『数学ガール/フェルマーの最終定理』 も発売になる。

今月は素敵な月。

[Common Lisp] 文字列リテラルを作る

こんなふうに書きたくて(CL-INTERPOLのまねごと)

CL-USER> (let ((lang "Common Lisp"))
           #"""母国語は "#,lang," です。""")
"母国語は \"Common Lisp\" です。"
CL-USER> (cl-ppcre:scan-to-strings #"""a\d+a""" "axaa123a")
"a123a"
#()
CL-USER> #"(+ 1 2) => #,(+ 1 2)"
"(+ 1 2) => 3"
CL-USER> (read-from-string "#\"(+ 1 2) => #,(+ 1 2)\"")
(FORMAT NIL "(+ 1 2) => ~a" (+ 1 2))
23

こんなふうに作ってみた。

(defun |#"-reader| (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (|#"-parser|
   (if (equal #\" (peek-char nil stream t nil t))
     (progn
       (read-char stream)
       (if (equal #\" (peek-char nil stream nil nil t))
         (|#"""-reader"""| stream)
         ""))
     (|#"-reader"| stream))))

(defun |#"-reader"| (stream)
  (funcall (get-macro-character #\") stream #\"))

(defun |#"""-reader"""| (stream)
  #1=(read-char stream t nil t)
  (with-output-to-string (*standard-output*)
    (loop for c1 = #1# then c2
          for c2 = #1# then c3
          for c3 = #1# then #1#
          until (char= #\" c1 c2 c3)
          do (write-char c1))))

(defun |#"-parser| (s)
  (macrolet ((peek-equal (c)
               `(equal ,c (peek-char nil in nil nil))))
    (let* ((args nil)
           (format
            (with-output-to-string (out)
              (with-input-from-string (in s)
                (loop for c = #1=(read-char in nil nil)
                      while c
                      if (and (equal #\# c) (peek-equal #\,))
                        do (progn
                             #1#
                             (write-string "~a" out)
                             (push (read-preserving-whitespace in) args)
                             (when (peek-equal #\,)
                               #1#))
                      else
                        do (write-char c out))))))
      `(format nil ,format ,@(reveres args)))))

(set-dispatch-macro-character
 #\# #\" '|#"-reader|)

またあとで |#"-parser| をもっといじる。

(char= #\a nil) はエラーになるのね。(equal #\, #\c1 #\c2 #\c3) と書けるけど、(equal #\, #\c1 #\c2 #\c3) とは書けないのね。

""" は Python から。

[Common Lisp] Wassar のコード片

(defun map-fringe (function tree)
  (with-ca/dr tree
    (cond ((endp tree)
           nil)
          ((atom car)
           (cons (funcall function car)
                 #1=(map-fringe function cdr)))
          (t
           (cons (map-fringe function car)
                 #1#)))))

(defun maybe-anaphora-symbol (sym)
  (and (symbolp sym)
       (< 1 (length (symbol-name sym)))
       (char= (char (symbol-name sym) 0) #\@)
       (intern (subseq (symbol-name sym) 1))))

(defmacro with-status (status &body body)
  (let* (syms
         (form (map-fringe (lambda (x)
                             (aif (maybe-anaphora-symbol x)
                                  (progn (pushnew it syms)
                                         it)
                                  x))
                           body)))
    `(json:json-bind ,syms ,status
       ,@form)))

(mapc {with-status _
      (format t "~&~a(~a): ~a" @user_login_id @user.screen_name @text)}
      (json:decode-json-from-string
       (http-request "http://api.wassr.jp/statuses/friends_timeline.json"
                     :basic-authorization *basic-authorization*)))

[Forth] コンパイル時にスタックをいじると

"LET OVER LAMBDA" のサンプルで出てきた Forth のコードの話。

処理系は gforth で。

普通に 5 から 1 までを表示するコード。ちゃんと begin 〜 again の中に if 〜 then がはいっている。

: countdown
    begin
        dup 1 < if drop exit [ .s ] then
        dup .
        1-
    again ;

5 countdown

これを、コンパイル中にスタックをいじってみるたりすると、begin 〜 if 〜 again 〜 then なんて順番で書けたりする。普通の言語ならコンパイルエラーだが、これはちゃんと動作する。

: countdown2
    begin
        dup 1 >= if dup . 1-
            [ rot drop 2swap 0 -rot ]
        again
    then
    drop ;

5 countdown2

次の部分で again のジャンプ先と if で偽だった場合のジャンプ先を入れ替えている。LOL のサンプルでは [ swap ] だったけど gforth では begin も if ともに 2 つの値をスタックに積むようで、さらにダミーの 0 が間に入っていたいりするので強引にいれかえるコードになってしまった。ん？ 3つの値をつむのか。

[ rot drop 2swap 0 -rot ]

Forth ではこんなふうに文法さえ無視することができる。もちろん Forth だから文法なんかじゃなくて、begin も again も if も then も単なる word(関数)でしかないのだけどね。

こんなことができたりするから Forth はたまらない。

あれ？ コードに色が付かない。。。

娘はお泊り保育

今日は娘はお泊り保育でいない。いつも夜更かしのあのこはちゃんと眠れているかな。

[Common Lisp] 第7回 慢性的CL勉強会@Lingr 8時だョ!全員集合 のお題 The Common Lisp Cookbook - The Loop Macro を SERIES で

第7回 慢性的CL勉強会@Lingr 8時だョ!全員集合 のお題 The Common Lisp Cookbook - The Loop Macro を SERIES で。

サンプルコードによるSERIES入門 (番外編) は素晴しい。SERIES もっとはやるといいな。

;;;; The Common Lisp Cookbook - The Loop Macro
;;;; (http://cl-cookbook.sourceforge.net/loop.html)
;;;; を SERIES でやってみる。
;;;;
;;;; マニュアルはソースにくっついてくる s-doc.txt

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :series))

(in-package :series)

;; #Z, #M を使えるようにする。
(eval-when (:compile-toplevel :load-toplevel :execute)
  (install))

;;; a〜e を print する。
(#Mprint #z(a b c d e))
;; #Z(A B C D E)
;;; #M... は (map-fn t #'... と同じ。
(map-fn t #'print #z(a b c d e))
;; #Z(A B C D E)


;;; 2つのシリーズを1つに
(#Mlist #z(a b c d e) #z(1 2 3 4 5))
;; #Z((A 1) (B 2) (C 3) (D 4) (E 5))


;;; 1〜5 のシリーズをつくって、2倍する。
(mapping ((i (scan-range :from 1 :upto 5)))
         (* 2 i))
;; #Z(2 4 6 8 10)


;;; 条件は普通に書ける。iterate は副作用を目的とする場合に。
(iterate ((x #z(a b c d e))
          (y (scan-range :from 1)))
         (when (> y 1)
           (format t ", "))
         (format t "~A" x))
;; A, B, C, D, E
;; NIL


;;; (scan-range :from 1) は無限だけど #z(a b c d e) の方で停止する。
(iterate ((x #z(a b c d e))
          (y (scan-range :from 1)))
         (if (> y 1)
           (format t ", ~A" x)
           (format t "~A" x)))
;; A, B, C, D, E
;; NIL


;;; until で停止させる。
(let* ((s #z(a b c d e 1 2 3 4))
       (b (#Mnumberp s)))
  (mapping ((x (until b s)))
           (list x 'foo)))
;; #Z((A FOO) (B FOO) (C FOO) (D FOO) (E FOO))


;;; これも until で停止
(let* ((x (scan-range :from 1))
       (y (#M(lambda (x) (* x 10)) x))
       (b (#M(lambda (y) (>= y 100)) y)))
  (mapping ((x x) (y (until b y)))
           (print (* x 5))
           y))
;; #Z(10 20 30 40 50 60 70 80 90)


;;; 二重ループ
(#M(lambda (x) (scan-range :from 1 :upto x))
   (scan-range :from 1 :upto 10))
;; #Z(#Z(1) #Z(1 2) #Z(1 2 3) #Z(1 2 3 4) #Z(1 2 3 4 5) #Z(1 2 3 4 5 6) #Z(1 2 3 4 5 6 7) #Z(1 2 3 4 5 6 7 8) #Z(1 2 3 4 5 6 7 8 9) #Z(1 2 3 4 5 6 7 8 9 10))


;;; destructuring-bind したいのだけど。。。
;; なんかいい手はないかな？
(mapping ((x #z((x 1) (y 2) (z 3))))
         (list (cadr x) (car x)))
;; #Z((1 X) (2 Y) (3 Z))


;;; 苦しい。previous がないと #\a がかえっちゃう。
(let ((s (scan "alpha45")))
  (collect-last
   (until
    (previous (#M(lambda (ch)
                   (find ch "0123456789" :test #'eql))
                 s) nil)
    s)))
;; #\4


;;; 1つでも真があれば
(collect-or (#Mnumberp #z(foo 2)))
;; T


;;; 1つも真でなければ
;; not をかますしかないのかな？
(collect-and (#Mnot (#Mnumberp #z(foo 2))))
;; NIL


;;; 全て真なら
(collect-and (#Mnumberp #z(foo 2)))
;; NIL

[Common Lisp] L-99 の P01 のために SERIES を拡張してみた

L-99 の P01 のために SERIES を拡張してみた。

g000001 さんが楽しんでらっしゃる L-99 を SERIES でやってみようかな、と思ったらさっそく一問目からつまずいた。

最後の要素をとってくる collect-last はあっても、最後のセルをとってくる関数がみあたらない。しかたないので collect-last-cons を作ってみた。でも、よくわかっていない。

fragl(どういう意味だろう？）手強い。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :series))

(in-package :series)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (install))

(defS collect-last-cons (items)
  "P01"
  (fragl ((items t))                    ; args
         ((cons))                       ; rets
         ((cons list nil))              ; aux
         ()                             ; alt
         ()                             ; prolog
         ()                             ; body
         ((setq cons (list items)))     ; epilog
         ()                             ; wraprs
         nil)                           ; ?
  :trigger t)

(assert (equal '(d)
               (collect-last-cons #z(a b c d))))

;; 展開するとこうなる。なので新しい cons を返してしまっている。
(pprint (macroexpand-1 '(collect-last-cons #z(a b c d))))
;; (COMMON-LISP:LET* ((#:LISTPTR-842 '(A B C D)) #:ELEMENTS-843)
;;   (DECLARE (TYPE LIST #:LISTPTR-842))
;;   (TAGBODY
;;    #:LL-844
;;     (IF (ENDP #:LISTPTR-842) (GO END))
;;     (SETQ #:ELEMENTS-843 (CAR #:LISTPTR-842))
;;     (SETQ #:LISTPTR-842 (CDR #:LISTPTR-842))
;;     (GO #:LL-844)
;;    END)
;;   (LIST #:ELEMENTS-843))

[Common Lisp] list 関数の定義

なるほど。list が呼び出されるとき、すでに list がすべき仕事は終っているのか。

SBCL のソース

(defun list (&rest args)
  #!+sb-doc
  "Return constructs and returns a list of its arguments."
  args)

[Common Lisp] LET OVER LAMBDA でステートマシン

LISPUSER さんとこの Common Lisp で簡単ステートマシンマクロ で題材になっているステートマシンを LET OVER LAMBDA でやってみようかと思ったら、ちょっと違った方向にいってしまった。

plambda は自身の手続を this に持っていて、それを外部から書きかえて状態が遷移できる、という予定だったけど、何故か case* マクロを書いておわってしまった。

this の書きかえはまたそのうちに。

(defpan print-status (tray player)
  (format t "~&tray => ~a~%player => ~a" tray player))

(let* ((tray :close)
       (player :stop)
       (cd-player (plambda (action) (tray player)
            (format t "~&Action: ~a" action)
            (case* (action tray player)
              ((:open :close :play)
               (print ">>> STOP")
               (setf player :stop)
               (print ">>> OPEN")
               (setf tray :open))
              ((:open :close :stop)
               (print ">>> OPEN")
               (setf tray :open))
              ((:close :open _)
               (print ">>> CLOSE")
               (setf tray :close))
              ((:play :close :stop)
               (print ">>> PLAY")
               (setf player :play))
              ((:play :open _)
               (print ">>> CLOSE")
               (setf tray :close)
               (print ">>> PLAY")
               (setf player :play))
              ((:stop _ _)
               (print ">>> STOP")
               (setf player :stop))
              (t
               (warn "Ignore action: ~a for tray: ~a, player: ~a."
                     action tray player)
               :ignore)))))
  (funcall cd-player :play)
  (funcall cd-player :open)
  (funcall cd-player :open)
  (funcall cd-player :play)
  (funcall cd-player :stop)
  (funcall cd-player :open)
  (funcall cd-player :close)
  (print-status cd-player))

(defmacro case* (keyform &body cases)
  `(cond ,@(mapcar #`(,(if (consp (car a1))
                         `(and
                           ,@(loop for k in keyform
                                   for v in (car a1)
                                   unless (eq v '_)
                                   append `((eq ,k ,v))))
                         t)
                       ,@(cdr a1))
            cases)))

[Common Lisp] lambda と書くのがめんどうなときに。{}

[] は CLSQL で使うから {} にしてみよう。

(set-macro-character
 #\{
 (lambda (stream char)
   (declare (ignore char))
   `(_ ,@(read-delimited-list #\} stream t))))

(set-macro-character #\} (get-macro-character #\)))

Stefil というテストフレームワークを使ったテスト

;;{} を使ったパターン
(deftest |test-{}| ()
  (is (equal '((2) (3) (4)) (mapcar {list (1+ _)} '(1 2 3))))
  (is (equal '(1 4 9) (mapcar {* _ _} '(1 2 3))))
  (is (equal '((1 a "A") (2 b "B"))
             (mapcar {list _z _y _x} '("A" "B") '(a b) '(1 2))))
  (is (equal '(1 2 3)
             (funcall {identity _rest} 1 2 3)))
  (is (equal '(2 1 3 4)
             (funcall {apply #'list _b _a _rest} 1 2 3 4)))
  (is (equal "a"
             (with-output-to-string (*standard-output*)
               (funcall {princ _} #\a))))
  (is (equal "abc"
             (with-output-to-string (*standard-output*)
               (funcall {(princ _x) (princ _y) (princ _z)} #\a #\b #\c)))))
;;{} を使わないパターン
(deftest |test-_| ()
  (is (equal '((2) (3) (4)) (mapcar (_ list (1+ _x)) '(1 2 3))))
  (is (equal '(1 4 9) (mapcar (_ * _x _x) '(1 2 3))))
  (is (equal '((1 a "A") (2 b "B"))
             (mapcar (_ list _z _y _x) '("A" "B") '(a b) '(1 2))))
  (is (equal '(1 2 3)
             (funcall (_ identity _rest) 1 2 3)))
  (is (equal '(2 1 3 4)
             (funcall (_ apply #'list _b _a _rest) 1 2 3 4)))
  (is (equal "a"
             (with-output-to-string (*standard-output*)
               (funcall (_ princ _x) #\a))))
  (is (equal "abc"
             (with-output-to-string (*standard-output*)
               (funcall (_ (princ _x) (princ _y) (princ _z)) #\a #\b #\c)))))

やっぱりマクロキャラクタを使った方がいいかな。マクロキャラクタの問題点はパッケージ内に閉じずグローバルだってとこ。だからこそ便利なんだろうけどね。

いや、そうなのかな？ このマクロキャラクタと Forth の仕組みってよく似てるし、また考えてみよう。

[Common Lisp] lambda と書くのがめんどうなときに。ちょっと考えなおした。

#_(* 2 _a) より (_ * 2 _a) でいいか。(_ (declare (optimize (speed 3))) (_ * 2 _a)) こっちは自然だな。いっそのこと [* 2 _a] とも思う(Arc!)が () に [] がまざるのに強烈な違和感を感じる(慣れるかな？)。(_ * 2 _) これでもいける。

(defmacro _ (&rest body)
  (let ((syms
         (sort
          (remove-duplicates
           (remove-if-not (lambda (x)
                            (and (symbolp x)
                                 (head-p (symbol-name x) "_")))
                          (flatten body)))
          #'string<=
          :key #'symbol-name)))
    (let ((rest (find '_rest syms :key #'symbol-name :test #'string=)))
      (when rest
        (setq syms (append (remove rest syms) `(&rest ,rest)))))
    (if (consp (car body))
      `(lambda ,syms
         ,@body)
      `(lambda ,syms
         ,body))))

[Common Lisp] Lisp isn't a language, it's a building material. — Alan Kay

Common Lisp も Lisp だから、好きなように使えばいいんだ。いままでなんとなく Common Lisp の流儀からそれないように、と思ってたけどそんな必要はない。だって Lisp だもん。
『LET OVER LAMBDA』を読んでふっきれた。

[Common Lisp] lambda と書くのがめんどうなときに

たまにはブログになんか書かないと。で、ありがちかもしれないが lambda と書くのがめんどうなときに ディスパッチマクロキャラクタ でちょっと楽してみよかな。#_ で始まるフォームを lambda フォームに変換する。_ で始まるシンボルがその lambda の引数。&rest は _rest を使う。

使い方はこんなかんじ。

;;(mapcar (lambda (x) * x x) '(1 2 3 4))
(mapcar #_(* _x _x) '(1 2 3 4))
;; => (1 4 9 16)

;;(mapcar (lambda (a b) (format nil "~d-~d=~d" b a (- b a)))
(mapcar #_(format nil "~d-~d=~d" _b _a (- _b _a))
        '(1 2 3 4)
        '(10 20 30 40))
;; => ("10-1=9" "20-2=18" "30-3=27" "40-4=36")

;;(mapcar (lambda (&rest rest) (apply #'* rest)) '(1 2 3) '(4 5 6) '(7 8 9))
(mapcar #_(apply #'* _rest) '(1 2 3) '(4 5 6) '(7 8 9))
;; => (28 80 162)

'#_(* _x _x)
;; => (_ (* _X _X))

(macroexpand-1 '#_(* _x _x))
;; => (LAMBDA (_X) (* _X _X))

実装はこんなかんじ。

(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x)
                           (rec (cdr x) acc))))))
    (rec x nil)))

(defgeneric head-p (whole part)
  (:method ((whole string) (part string))
    (let ((part-length (length part)))
      (and (>= (length whole) part-length)
           (string= whole part
                    :end1 part-length))))
  (:method ((whole symbol) (part string))
    (head-p (symbol-name whole) part)))

(defmacro _ (&rest body)
  (let ((syms
         (sort
          (remove-duplicates
           (remove-if-not (lambda (x)
                            (and (symbolp x)
                                 (head-p (symbol-name x) "_")))
                          (flatten body)))
          #'string<=
          :key #'symbol-name)))
    (let ((rest (find '_rest syms :key #'symbol-name :test #'string=)))
      (when rest
        (setq syms (append (remove rest syms) `(&rest ,rest)))))
    (find '_rest '(_a _rest _b))
    `(lambda ,syms
       ,@body)))

(set-dispatch-macro-character
 #\# #\_
 (lambda (stream subchar arg)
   (declare (ignore subchar arg))
   (let ((form (read stream t nil t)))
     (if (consp (car form))
       `(_ (progn ,@form))
       `(_ ,form)))))