ストリームのパス
pathname でとれたのね。
(setq x (open "/tmp/foo" :direction :output))
;;=> #<SB-SYS:FD-STREAM for "file /tmp/foo" {100A91F581}>
(pathname x)
;;=> #P"/tmp/foo"
(close x)
;;=> T
(pathname x)
;;=> #P"/tmp/foo"
2011/07/09
2011/07/03
PAIProlog に atom-characters/2, string-atom/2, string-list/2 を実装
atom-characters/2, string-atom/2, string-list/2 を実装した。
https://github.com/quek/paiprolog
PAIPROLOG> (prolog-first (?x)
(atom-characters ?x (#\H #\E #\L #\L #\O)))
HELLO
PAIPROLOG> (prolog-first (?x)
(atom-characters ?x (#\H #\E #\L #\l #\O)))
|HELlO|
PAIPROLOG> (prolog-first (?x)
(atom-characters hello ?x))
(#\H #\E #\L #\L #\O)
PAIPROLOG> (prolog-first (?x)
(string-atom "hello" ?x))
|hello|
PAIPROLOG> (prolog-first (?x)
(string-atom ?x hello))
"HELLO"
PAIPROLOG> (prolog-first (?x)
(string-atom ?x |hello|))
"hello"
PAIPROLOG> (prolog-first (?x)
(string-list "hello" ?x))
(#\h #\e #\l #\l #\o)
PAIPROLOG> (prolog-first (?x)
(string-list ?x (#\h #\e #\L #\l #\o)))
"heLlo"
2011/06/19
SERIES の producing の中での setf
次のように SERIES の producing の中での setf を使うと (setf b (car a)) のところが (setf nil (car a)) になりエラーとなる。
(defun foo ()
(declare (optimizable-series-function))
(producing (z) ((a '(1 2 3)) b)
(loop
(tagbody
(if (endp a)
(terminate-producing))
(setf b (car a))
(setf a (cdr a))
(next-out z b)))))
(collect (foo))
s-code.lisp をながめると
;;;; 13. Allow `SETF like SETQ' in PRODUCING forms.
とあるのだけど、
(cond ((and (consp f) (case (car f) ((setq) t))) ; setf removed for now
(cl:multiple-value-bind (vars lastbind binds) (detangle2 (cdr f))
(unless (cdr lastbind)
(ers 50 "~%missing value in assignment: " f))
;; setf still not supported - need to make caller setf-aware
(cl:let ((expr (cons 'setq ; should be setf
(mapcan #'xform-assignment vars binds))))
;;(format t "~s" expr)
(push expr revbody))))
...)
今はみたいなことになっている。
きっと何か問題があったんだろうけど、なんだろう？とりあえず、case のところだけ
(case (car f) ((setq setf) t))
にしてみたら上記の foo は動いたけど
(defun foo ()
(declare (optimizable-series-function))
(producing (z) ((a '(1 2 3)) (b (list nil)) c)
(loop
(tagbody
(if (endp a)
(terminate-producing))
(setf (car b) (car a))
(setf c b)
(setf a (cdr a))
(next-out z c)))))
みたいのは動かない。 ; should be setf のところを setf にしたら、 (SETQ NIL #:OUT-2) になってだめ。
ってところで力つきた。。。
[2011-06-21] ちょっとちがったので修正した。
2011/06/18
SERIES を series:install して使うときの defpackage
LET LET* MULTIPLE-VALUE-BIND FUNCALL DEFUN を shadowing import するので defpackage をラップするマクロがあると楽。
(defmacro sdefpackage (package &rest options)
`(progn
(defpackage ,package
,@options
(:use :series)
(:shadowing-import-from :series ,@series::/series-forms/))
(series::install :pkg ,package :implicit-map t)))
2011/06/05
change-class でモードの実装
McCLIM の ESA では change-class を使ってバッファ（エディタ）のモードを実装している。それそまねて、少しコードを書いてみた。
ESA では "anonymous classes are the ugly child of CL" ということで、あえて無名クラスではなく defclass を eval するようにしている（ESA/utils.lisp）。私の方は何も考えず無名クラスでいってみようと思う。
有効にするモードをスーパークラスにし指定して standard-class を make-instance して、それに change-class する。多重継承大好き。
ところで、McCLIM のソースは MOP のいろんな機能を使っていておもしろい。
(in-package :info.read-eval-print.editor)
(defun anonymous-class-p (class)
(null (class-name class)))
(defgeneric enable-mode (mode mode-to-enable &rest initargs)
(:method (mode mode-to-enable &rest initargs)
(let* ((current-class (class-of mode))
(superclasses (cons(find-class mode-to-enable)
(if (anonymous-class-p current-class)
(c2mop:class-direct-superclasses current-class)
(list current-class))))
(new-class (make-instance 'c2mop:standard-class
:direct-superclasses superclasses)))
(apply #'change-class mode new-class initargs))))
(defgeneric disable-mode (mode mode-to-disable &rest initargs)
(:method (mode mode-to-disable &rest initargs)
(let* ((current-class (class-of mode))
(superclasses (remove (find-class mode-to-disable)
(c2mop:class-direct-superclasses current-class)))
(new-class (make-instance 'c2mop:standard-class
:direct-superclasses superclasses)))
(apply #'change-class mode new-class initargs))))
(defgeneric enabled-mode (mode)
(:method (mode)
(let ((class (class-of mode)))
(if (anonymous-class-p class)
(collect (class-name (scan (c2mop:class-direct-superclasses class))))
(list (class-name class))))))
(defgeneric key-binding (mode keyseq)
(:method-combination or))
(defclass* key-map ()
((map (make-hash-table :test #'equal))))
(defclass* mode ()
((name nil)
(key-map (make-instance 'key-map))))
(defclass* fundamental-mode (mode)
())
(defclass* lisp-mode (mode)
())
(defclass* common-lisp-mode (lisp-mode)
())
(defclass* show-paren-mode (mode)
())
(defmethod print-object ((x mode) stream)
(print-unreadable-object (x stream)
(format stream "~a ~(~{~a~^ ~}~)" (name-of x) (enabled-mode x))))
(let ((x (make-instance 'fundamental-mode :name "*scratch*")))
(print x)
(enable-mode x 'common-lisp-mode)
(print x)
(enable-mode x 'show-paren-mode)
(print x)
(disable-mode x 'common-lisp-mode)
(print x)
(disable-mode x 'show-paren-mode)
(print x))
;;->
;; #<*scratch* fundamental-mode>
;; #<*scratch* common-lisp-mode fundamental-mode>
;; #<*scratch* show-paren-mode common-lisp-mode fundamental-mode>
;; #<*scratch* show-paren-mode fundamental-mode>
;; #<*scratch* fundamental-mode>
;;=> #<*scratch* fundamental-mode>
(let ((x (make-instance 'c2cl:standard-class
:direct-superclasses (list (find-class 'common-lisp-mode)
(find-class 'show-paren-mode)))))
(print (c2mop:class-direct-superclasses x))
(print (make-instance x :name "ま"))
x)
;;->
;; (#<STANDARD-CLASS COMMON-LISP-MODE> #<STANDARD-CLASS SHOW-PAREN-MODE>)
;; #<ま (COMMON-LISP-MODE SHOW-PAREN-MODE)>
;;=> #<STANDARD-CLASS NIL {10048B11E1}>
2011/05/15
change-class が便利
CL-Gtk2 を触ってみたらとてもよかったので、エディタを使ってみている。
GtkSourceBuffer で編集対象をあつかうただが、オープンしたファイル名なども一緒に GtkSourceBuffer に持っていてほしい。
そこで change-class してみた。
GtkSourceBuffer は CL-Gtk2 では source-buffer クラスになっている。 source-buffer クラスを継承して欲しいスロットを持ったクラスを作る。 source-buffer のインスタンスができたところで、その作ったクラスに change-class する。
(defclass* buffer (source-buffer)
((view)
(name nil)
(file nil)
(yank "AAAA")
(digit-argument nil :accessor nil)
(external-format :utf-8))
(:metaclass gobject-class))
(change-class (make-instance 'source-buffer)
'buffer
:name "command buffer")
動的プロキシとかデリゲートとか意味ないな (特異メソッドはまた違う話しか) 。
MOP なら動的にスーパークラスを追加する手もあるかもしれない。
あっ、make-instance したのを change-class するのはひどい例だった。
2011/05/08
Google Code Jam Qualification Round 2011
参加した。
もちろん使用言語は Common Lisp
A Bot Trust
オレンジが仕事している間もブル一は仕事できる。まずは、 O の仕事と B の仕事をグルーピングしよう。 loop で書きかけたら、何だか書きにくい。再帰で書く。
あ、だめだ。 B 1 B 2 と連続していたら、O が仕事している間にできるのは、 B 1 の分だけだ。 (setf prev-sec 0) が必要。
ボタンを押す分を足すの忘れてる。 1+ 追加。
2ヵ所で (if (eq curr-robot 'o) とか判定してるのきたないな。。。ま、いいか。
うん、動いた。よさそう。
入力は、リーダがあってよかった。
Small も Larg もかわらないね。
;;;; Google Code Jam
;;;; Qualification Round 2011
;;;; A Bot Trust
;;;; Common Lisp
;;;; 46min
(defun grouping (x &optional acc last-color)
(if (null x)
(mapcar #'nreverse (nreverse acc))
(let ((color (car x))
(button (cadr x)))
(if (eq color last-color)
(push button (car acc))
(push (list button) acc))
(grouping (cddr x) acc color))))
(defun compute (seq)
(loop with o-pos = 1
with b-pos = 1
for prev-sec = 0 then curr-sec
for curr-robot = 'o then (if (eq curr-robot 'o) 'b 'o)
for xs in seq
for curr-sec = (loop for x in xs
sum (prog1
(max 1 (- (1+ (abs (- x (if (eq curr-robot 'o) o-pos b-pos))))
prev-sec))
(setf prev-sec 0)
(if (eq curr-robot 'o)
(setf o-pos x)
(setf b-pos x))))
sum curr-sec))
(compute (grouping '(O 2 B 1 B 2 O 4)))
;;=> 6
(compute (grouping '(O 5 O 8 B 100)))
;;=> 100
(compute (grouping '(B 2 B 1)))
;;=> 4
(defun read-input ()
(loop repeat (read)
collect (loop repeat (read)
append (list (read) (read))) ))
(defun main ()
(loop for x in (read-input)
for i from 1
do (format t "Case #~d: ~d~%" i (compute (grouping x)))))
(defun main-with-file (input-file)
(let ((input-file (make-pathname :name (pathname-name input-file)
:type (pathname-type input-file)
:defaults "~/letter/lisp/try/google-code-jam/2011/a/qualification-round/")))
(with-open-file (*standard-input* input-file)
(with-open-file (*standard-output* (make-pathname :defaults input-file :type "out")
:direction :output :if-exists :supersede)
(main)))))
;;(main-with-file "A-small-attempt0.in")
(main-with-file "A-large.in")
B Magicka
えっと、、、複雑だな。
愚直にとけばいいのか。Q F が来たら T になる。あ、Q が残っちゃってる。 (setf acc (cons combine acc)) じゃなって (setf acc (cons combine (cdr acc))) だ。
愚直にといて Large でも問題ないみたい。
;;;; Google Code Jam
;;;; Qualification Round 2011
;;;; B Magicka
;;;; Common Lisp
;;;; 70min
(declaim (optimize (debug 3) (safety 3)))
(defun compute-combine (a b combines)
(and a
(loop for (x y z) in combines
if (or (and (eq x a) (eq y b))
(and (eq x b) (eq y a)))
do (return-from compute-combine z))
nil))
(defun opposed-p (acc opposds)
(loop for (x y) in opposds
thereis (and (member x acc)
(member y acc))))
(defun compute (combines opposeds invokes)
(loop with acc = nil
for x in invokes
for combine = (compute-combine (car acc) x combines)
if combine
do (setf acc (cons combine (cdr acc)))
else
do (push x acc)
end
if (opposed-p acc opposeds)
do (setf acc nil)
end
finally (return (nreverse acc))))
(compute '() '() '(e a))
;;=> (E A)
(compute '((q r i)) '() '(r r q r))
;;=> (R I R)
(compute '((q f t)) '((q f)) '(f a q f d f q))
;;=> (F D T)
(compute '((e e z)) '((q e)) '(q e e e e r a))
;;=> (Z E R A)
(compute '() '((q w)) '(q w))
;;=> NIL
(defun str->sym (str)
(loop for c across (string-upcase str)
collect (intern (string c))))
(defun read-input ()
(loop repeat (read)
collect (list #1=(loop repeat (read)
collect (str->sym (read)))
#1#
(progn (read) (str->sym (read))))))
(defun main ()
(loop for x in (read-input)
for i from 1
do (format t "Case #~d: [~{~a~^, ~}]~%" i (apply #'compute x))))
(defun main-with-file (input-file)
(let ((input-file (make-pathname :name (pathname-name input-file)
:type (pathname-type input-file)
:defaults "~/letter/lisp/try/google-code-jam/2011/a/qualification-round/")))
(with-open-file (*standard-input* input-file)
(with-open-file (*standard-output* (make-pathname :defaults input-file :type "out")
:direction :output :if-exists :supersede)
(main)))))
;;(main-with-file "B-small-attempt0.in")
(main-with-file "B-large.in")
C Candy Splitting
これは logxor か。 2進にして縦にならべてみる。
001
010
011
100
101
NO になるのは、ある bit で 1 が奇数個の場合。各 bit 毎に 1 の数をかぞえればいいのか。一番大きな bit は integer-length でとれる。
いや、単に全部を logxor して 0 じゃなければ NO なんだ。 (not (zerop (apply #'logxor list)))
さて、どうやって分けるか。総当たりだときっと large でだめだよな。
うぅん、わかんない。先に D を見てみよう。と、D を見てみたが D もわからないので、また C に戻る。
もう一度2進で縦に並べたものをながめる。あれ、どこど分けてもいいんじゃないのか。どこで分けても xor で綺麗になる。本当か？ 本当っぽいな。これはひどい Patrick があまりにもかわいそうだろう。
何も考えず総当たりでやっても、全部一回目で当たりだから問題なかったんだ。
;;;; Google Code Jam
;;;; Qualification Round 2011
;;;; C Candy Splitting
;;;; Common Lisp
;;;; 2.5h
#|
5 + 4 = 1
7 + 9 = 14
50 + 10 = 56
#b0101 #b100 #b0001
(logxor #b0101 #b100)
;;=> 1
#b0001
(logxor #b0111 #b1001)
;;=> 14
#b1110
(logxor #b110010 #b1010)
;;=> 56
#b111000
1 2 3 4 5 Case #1: NO
001
010
011
100
101
3 5 6 Case #2: 11
011
101
110
(logxor 5 6)
;;=> 3
011
101
110
100
100
|#
(defun no-p (list)
(not (zerop (apply #'logxor list))))
(defun compute (list)
(unless (no-p list)
(let ((sorted (sort list #'<)))
(apply #'+ (cdr sorted)))))
(compute '(1 2 3 4 5))
;;=> NIL
(compute ' (5 3 6))
;;=> 11
(defun read-input ()
(loop repeat (read)
collect (loop repeat (read)
collect (read))))
(defun main ()
(loop for x in (read-input)
for i from 1
do (format t "Case #~d: ~:[NO~;~:*~d~]~%" i (compute x))))
(defun main-with-file (input-file)
(let ((input-file (make-pathname :name (pathname-name input-file)
:type (pathname-type input-file)
:defaults "~/letter/lisp/try/google-code-jam/2011/a/qualification-round/")))
(with-open-file (*standard-input* input-file)
(with-open-file (*standard-output* (make-pathname :defaults input-file :type "out")
:direction :output :if-exists :supersede)
(main)))))
;;(main-with-file "C-small-attempt0.in")
(main-with-file "C-large.in")
D GoroSort
確率か。苦手だ。勉強が必要だなと思っているところ。
10 の -6 乗の精度って普通に float してもだめなんだ。 (float 1/3 0d0) と書くのか。
Goro の最適な戦略は何だろう。 Sample #3 の説明には 2 個ずつソートすると書いてある。全部まとめてソートした方がはやくないのか。
2 つずつのソートがベストだと仮定してやってみると Small で失敗。
3 1 2 のソートで考えてみよう。 2 つずつより 3 つまとめての方がはやいように思えるんだけど。。。いくら考えてもわからん。
Large の N は最大 1000 なんで、何か簡単に求める方法があるはず。。。
仕方ないシミュレートしてみよう。シミュレートの方法は入力のリストをそのソート済みのものと 1 要素ずつ比較して、一致しないものだけ collect して新しいリストを作る。できた新しいリストをシャッフルして、あとは空になるまで繰り返す。これで試めしてみると 2 1 4 3 を 2 つずつソートするのと全部まとめてソートするのでステップ数はかわらない。他にも色々試めしてみると、初期状態でソート済の位置にないものの個数がそのまま答えになっているっぽい。そんなものなのか。さっぱり理解できない。 Small やってみたら。通った。ならあってるんだろうと Large を提出。
;;;; Google Code Jam
;;;; Qualification Round 2011
;;;; D GoroSort
;;;; Common Lisp
;;;; 30min 13:00-
#|
(float 1/3 0d0)
;;=> 0.3333333333333333d0
(3 1 2)
---
a (1 2 3) 1/6
b (1 3 2) 1/2 * 1/2
b (2 1 3)
b (3 2 1)
c (2 3 1)
c (3 1 2)
N=3
(+ 1/6 1/12 1/12 1/12)
;;=> 5/12
(float (/ 1 5/12))
;;=> 2.4
|#
(defun shuffle (list)
(let ((list (copy-list list)))
(loop for len = (length list)
while list
collect (let ((n (nth (random len) list)))
(setf list (delete n list))
n))))
(defun count-sort-step (list sorted &optional (n 0))
(loop for a in list
for b in sorted
if (/= a b)
collect a into new-list
and collect b into new-sorted
finally (return
(if (null new-list)
n
(count-sort-step (shuffle new-list) new-sorted (1+ n))))))
#|
(simulate 1 2 3)
;;=> 0.0d0
(simulate 1 3 2)
;;=> 2.019098090190981d0
(simulate 3 1 2)
;;=> 2.996900309969003d0
(simulate 2 1 4 3)
;;=> 4.000099990001d0
(simulate 4 3 2 1)
;;=> 3.9836016398360163d0
(simulate 1 3 4 2)
;;=> 3.014898510148985d0
(simulate 1 4 3 2)
;;=> 2.0125987401259873d0
(simulate 1 2 3 4 5)
;;=> 0.0d0
(simulate 1 2 3 5 4)
;;=> 1.996000399960004d0
(simulate 1 3 2 5 4)
;;=> 3.978102189781022d0
(simulate 3 1 5 2 4)
;;=> 5.012198780121988d0
(simulate 3 1 5 2 6 4)
;;=> 6.052394760523947d0
(simulate 10 1 2 3 4 5 6 7 8 9)
;;=> 9.93890610938906d0
(4 3 2 1) 24
----
a (1 2 3 4) 1 1/24
b (1 2 4 3) 6 (* 6/24 1/2)
b (1 3 2 4)
b (1 4 3 2)
b (4 2 3 1)
b (3 2 1 4)
b (2 1 3 4)
c (1 3 4 2) 8 (* 8/24 5/12)
c (1 4 2 3)
c (3 2 4 1)
c (4 2 1 3)
c (4 1 3 2)
c (2 4 3 1)
c (2 3 1 4)
c (3 1 2 4)
d (2 1 4 3) 9
d (2 3 4 1)
d (2 4 1 3)
d (3 1 4 2)
d (3 4 1 2)
d (3 4 2 1)
d (4 1 2 3)
d (4 3 1 2)
d (4 3 2 1)
(+ 1/24 (* 6/24 1/2) (* 8/24 5/12))
;;=> 11/36
(float (/ 11/36))
;;=> 3.2727273
(2 1 4 3) => 4.000000
----
(2 1)
--
(1 2) 1/2
(2 1) 1/2
|#
(defun product (n &optional (acc 1))
(if (zerop n)
acc
(product (1- n)
(* n acc))))
#+(or)
(defun compute (array)
(loop with sorted = (sort (copy-seq array) #'<)
for x across array
for i from 0
if (= x (aref sorted i))
count 1 into ok
if (and (not (= x (aref sorted i)))
(let ((pos (position x sorted :start (1+ i))))
(and pos
(= (aref sorted i) (aref array pos)))))
count 1 into swap
finally (return (values (+ (* 2 swap)
(* 2 (max 0 (- (length array) ok (* swap 2) 1))))
(list :ok ok :swap swap :rest (- (length array) ok (* swap 2)))))))
(defun compute (array)
(loop with sorted = (sort (copy-seq array) #'<)
for a across array
for b across sorted
if (/= a b)
count 1))
#|
(compute #(3))
;;=> 0
;;=> 0
;; (:OK 1 :SWAP 0 :REST 0)
(compute #(2 4 1 3))
;;=> 4
;;=> 6
;; (:OK 0 :SWAP 0 :REST 4)
(compute #(2 1 4 3))
;;=> 4
;;=> 4
;; (:OK 0 :SWAP 2 :REST 0)
(compute #(2 1))
;;=> 2
;;=> 2
;; (:OK 0 :SWAP 1 :REST 0)
(compute #(1 3 2))
;;=> 2
;;=> 2
;; (:OK 1 :SWAP 1 :REST 0)
(compute #(3 1 2))
;;=> 3
;;=> 4
;; (:OK 0 :SWAP 0 :REST 3)
|#
(defun read-input ()
(loop repeat (read)
collect (coerce (loop repeat (read)
collect (read))
'vector)))
(defun main ()
(loop for x in (read-input)
for i from 1
do (format t "Case #~d: ~,6f~%" i (float (compute x) 1d0))))
(defun main-with-file (input-file)
(let ((input-file (make-pathname :name (pathname-name input-file)
:type (pathname-type input-file)
:defaults "~/letter/lisp/try/google-code-jam/2011/a/qualification-round/")))
(with-open-file (*standard-input* input-file)
(with-open-file (*standard-output* (make-pathname :defaults input-file :type "out")
:direction :output :if-exists :supersede)
(main)))))
;;(main-with-file "D-small-attempt2.in")
(main-with-file "D-large.in")
おわってから
ぐちゃぐちゃなものをぐちゃぐちゃなまま書ける loop は便利。入力もリーダのおかげで (read) するだけ。動かしながら書ける。 Common Lisp でよかったw
D は srot しなくてよかったのね。 n 個がランダムにおさまるなら、 (loop repeat n sum (/ 1 n)) なんで 1 になるのか。朝おきてトイレで納得した。 Case #3 の説明は罠だよ。
Code Jam 2011 Statistics に統計情報がある。 C++ って人気あるんだ。続いて Java, Python, C#, C, Ruby みたい。 Common Lisp は "Lisp" になっているようだけど、26 人が使っている。 Common Lisp はこういうのにはとても向いてると思うんだけどなぁ。
http://www.go-hero.net/jam/11/lang/Lisp で他の人のコードを見ると、みんなきれいなコードを提出してるのね。
あれ、D の simulate の定義消しちゃってた。確しかこんなんだったような。
(defun simulate (&rest list)
(loop with n = 10000
repeat n
sum (count-sort-step list (sort (copy-list list) #'<)) into total
finally (return (float (/ total n) 1d0))))
うん、おもしろかった。
登録:
投稿 (Atom)
