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 |

2007-11-19

CLOSチュートリアル (1)

| 15:37 | CLOSチュートリアル (1) - わだばLisperになる を含むブックマーク はてなブックマーク - CLOSチュートリアル (1) - わだばLisperになる

自分は、多少Lispでのリスト操作はできるようになった気はしますが、CLOSとなると全く訳が分かりません。

そもそもオブジェクト指向言語自体まともに触ったことが無いし、全く未知の領域で、Lispとオブジェクト指向がどう融合するのか見当もつきません。

しかし、CLOSは折角Common Lispに標準で付いてくるし、ちょっとは分かるようになれたら良いなと思っていた折、Common Lisp クックブックを訳されているid:cl-internさんのCommon Lisp クックブックで、CLOSの記事(

no title)の翻訳の開始を目にし、おおこれは素晴らしいと思っていたところ、丁度、練習問題が付いてくるようなので、良い機会なので練習問題に挑戦してみることにしました。

ということで早速挑戦。

CLOSチュートリアル 3.2. defclass マクロの練習問題より

  1. with-slots を使って set-point-values を書き直しなさい。
;; 解答
(defun set-point-values (point x-pos y-pos z-pos)
  (with-slots (x y z) point
    (setf x x-pos
	  y y-pos
	  z z-pos)))

with-slotsを使うと名前の衝突を起してしまうので、x-pos等として衝突を回避してみましたが、他に回避方法はあるのでしょうか。

with-slotsはマクロなので、マクロを展開して眺めてみても回避はできないっぽいんですが…。

  1. symbol-macrolet を使って with-slots を実装しなさい。symbol-macrolet の最初の引数は、次のペア (変数名 スロット名) のリストになります。
;; 解答
(defmacro my-with-slots ((&rest vars) instance &body body)
  (let ((inst (gensym "INST-")))
    `(let ((,inst ,instance))
       (declare (ignorable ,inst))
       (symbol-macrolet ,(mapcar (lambda (v) 
				   `(,v (slot-value ,inst ',v)))
				 vars)
	 ,@body))))

sbclのmacroexpandの結果から類推してマクロ作成。ちょっとズルかもしれない。

(my-with-slots (x y z) bar
  (list x y z))

(LET ((#:INST-2958 BAR))
  (DECLARE (IGNORABLE #:INST-2958))
  (SYMBOL-MACROLET ((X (SLOT-VALUE #:INST-2958 'X))
                    (Y (SLOT-VALUE #:INST-2958 'Y))
                    (Z (SLOT-VALUE #:INST-2958 'Z)))
    (LIST X Y Z)))

のように展開されます。

  1. defclass に defstruct の機能を追加したマクロ defclass-plus を実装しなさい。新しいクラスを定義したときに、そのクラスのコンストラクタ関数、述語関数、アクセサ関数、コピー関数も自動的に定義するようにします。退屈かもしれませんが、納得できるまでやってみてください。
;; 解答

;; 本体
(defmacro defclass-plus (name direct-super-classes direct-slots &rest options)
  `(prog1
     (defclass ,name ,direct-super-classes 
        ,(mapcar (lambda (s) `(,s :initarg ,(intern (string s) :keyword))) 
	         direct-slots)
          ,@options)
     (constructer-maker ,name)
     (pred-maker ,name)
     (accessor-maker ,name ,@direct-slots)
     (copier-maker ,name ,@direct-slots)
     (setter-maker ,name ,@direct-slots)))

;; 関数の名前を付けるための補助関数
(defun symbol-name-conc (&rest names)
  (values
   (intern 
    (string-upcase 
     (apply #'concatenate 'string (mapcar #'string names))))))

;; コンストラクタ関数 make-~を作るマクロ
(defmacro constructer-maker (name)
  `(defun ,(symbol-name-conc "MAKE-" name) (&rest initargs)
     (apply #'make-instance ',name initargs)))

;; 述語関数 ~-pを作るマクロ
(defmacro pred-maker (name)
  `(defun ,(symbol-name-conc name "-P") (object)
     (eq ',name (type-of object))))

;; アクセサ関数を作るマクロ
(defmacro accessor-maker (name &rest slots)
  `(progn
     ,@(mapcar (lambda (s) 
		 `(defun ,(symbol-name-conc name "-" s) (object)
		    (slot-value object ',s)))
	       slots)))

;; コピー関数を作るマクロ
(defmacro copier-maker (name &rest slots)
  (let ((new (gensym)))
    `(defun ,(symbol-name-conc "COPY-" name) (object)
       (setf ,new (make-instance ',name))
       (mapc (lambda (s) (setf (slot-value ,new s) (slot-value object s)))
	     ',slots)
       ,new)))

;; (setf (accessor-x object) 30)のようなことができるようにするマクロ
(defmacro setter-maker (name &rest slots)
  `(progn
     ,@(mapcar (lambda (s) 
		 (let ((name (symbol-name-conc name "-" s)))
		   `(define-setf-expander ,name (obj)
		    (let ((tem (gensym)))
		      (values nil nil `(,tem)
			      `(setf (slot-value ,obj ',',s) ,tem)
			      `(,',name ,obj))))))
	       slots)))

defstructの説明がこの前の章にあって、その機能の説明を全部盛り込むと結構複雑になりました。

(make-foo :x 40)のように初期値を取るようにするには、defclassで、:initargを使う必要があるようなので、まだチュートリアルに説明は出てきませんが、:initargを使ってみました。

色々使ったことが無い関数やマクロを触ることになったのでかなり試行錯誤という感じです。

また、謎なところでは、マクロの中で、:xや、:yを作る方法が分からず、(intern (string s) :keyword)とかしています。

安直に、`(:,keyword)のような感じで展開できると思っていたんですが、できなかったためですが、こういう時、普通はどうするんでしょう。

2007-09-26

L-99 (63)

| 02:58 | L-99 (63) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (63) - わだばLisperになる

L-99 P63に挑戦 - L-99:Ninety-Nine Lisp Problems

今回は、木の各ノードに番号を振ってゆくというお題。

左のノードを優先して埋めて行き、かつノードの番号付

けは、

         1
   2           3
 4    5     6     7
8 9 10 11 12 13 14 15

のようになるようなので、そういう風に作ったつもりで

ございます。

残りの問題:'(66 80-94 96-99) 解答状況 65/84

P63

回答
;;; ---------------------------------------------------------------------------
;;; common lisp
;;; ---------------------------------------------------------------------------
(load "max-nodes")

(defun complete-binary-tree (n &optional (base 1))
  (if (zerop n)
      ()
      (let ((cn-max-size (max-nodes (1- (cbt-height n))))
	    (gcn-max-size (max-nodes (- (cbt-height n) 2)))
	    (cn (1- n)))
	(cond ((= cn (* 2 cn-max-size))
	       `(,base ,(complete-binary-tree cn-max-size (* 2 base))
		       ,(complete-binary-tree cn-max-size (1+ (* 2 base)))))
	      ((> cn cn-max-size)
	       `(,base ,(complete-binary-tree cn-max-size (* 2 base))
		       ,(complete-binary-tree (- cn cn-max-size) (1+ (* 2 base)))))
	      ((<= cn cn-max-size)
	       `(,base ,(complete-binary-tree (- cn gcn-max-size) (* 2 base))
		       ,(complete-binary-tree gcn-max-size (1+ (* 2 base)))))))))

(defun cbt-height (n)
  (if (zerop n) n (1+ (truncate (log n 2)))))

2007-09-16

L-99 (60)

| 16:38 | L-99 (60) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (60) - わだばLisperになる

L-99 P60に挑戦 - L-99:Ninety-Nine Lisp Problems

P59変形で、高さの代わりにノード数を与え、バランス

の取れた木を生成するというお題。

残りの問題:'(63 66 80-94 96-99) 解答状況 64/84

P60

解答
N = 15のとき生成される木の組み合わせは、1553通り。
(length (hbal-tree-nodes 15))
=> 1553
;;; ---------------------------------------------------------------------------
;;; common lisp
;;; ---------------------------------------------------------------------------
(defun max-nodes (h)
  (1- (expt 2 h)))

(defun min-nodes (h)
  (do ((h h (1- h))
       (res 2 (+ 1 res acc))
       (acc 1 res))
      ((< h 3) res)))

#|(defun min-nodest (h a1 a2)
  (if (< h 3)
      a1
      (min-nodest (1- h) (+ 1 a1 a2) a1)))|#

(defun max-height (n)
  (do ((i 0 (1+ i)))
      ((> (min-nodes i) n) (1- i))))

(defun min-height (n)
  (1+ (truncate (log n 2))))

(defun hbal-tree-nodes (n)
  (let ((min-height (min-height n))
	(max-height (max-height n)))
    (do ((h min-height (1+ h))
	 res)
	((> h max-height) res)
      (setq res `(,@(remove-if-not (lambda (x) (= n (count-leaf x)))
				   (hbal-tree h))
		    ,@res)))))

2007-09-13

L-99 (59)

| 16:17 | L-99 (59) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (59) - わだばLisperになる

L-99 P59に挑戦 - L-99:Ninety-Nine Lisp Problems

今度は、木の高さのバランスを取りつつ与えられた高さ

の木を生成するというお題。

残りの問題:'(60 63 66 80-94 96-99) 解答状況 63/84

P59

;;; ---------------------------------------------------------------------------
;;; common lisp
;;; ---------------------------------------------------------------------------
(load "comb2")

(defun hbal-tree (h)
  (remove-if-not #'hbal-tree-p (gen-tree-h h)))

(defun gen-tree-h (h)
  (cond ((zerop h) '(()))
	((= h 1)   '((x () ())))
	((= h 2)   '((x (x () ()) () )
		     (x () (x () ()))
		     (x (x () ()) (x () ()) )))
	((> h 2)
	 (let ((h-1 (gen-tree-h (1- h)))
	       (h-2 (gen-tree-h (- h 2))))
	   (map 'list (lambda (item) `(x ,@item))
		`(,@(comb2 h-1 h-1)
		  ,@(comb2 h-1 h-2)
		  ,@(comb2 h-2 h-1))))
	('T (error "Bad arg to gen-tree-h"))))

(defun hbal-tree-p (tree)
  (>= 1 (abs (- (tree-height (cadr tree))
		(tree-height (caddr tree))))))

(defun tree-height (tree)
  (if tree
      (1+ (max (tree-height (cadr tree)) 
	       (tree-height (caddr tree))))
      0))

2007-09-12

L-99 (58)

| 12:30 | L-99 (58) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (58) - わだばLisperになる

L-99 P58に挑戦 - L-99:Ninety-Nine Lisp Problems

解けなかったP55が解けたので、関連するP58も解答を作

成。

57ノードの場合、16個のうちから13個取る組み合わせなの

で、nPr = n!/r!(n-r)!

で、560通りかと思いきや、自作プログラムの結果は、256。

560通りの組み合わせのうち自身のパターンが、

1010と0101の関係のように逆行系が同じになるパターン

を纏めれば、256になるのかもしれない。

考えても分からないので、元のPrologで作成されたプロ

グラムを実行してみたら、これも256。

理屈は全然分からないが、自作プログラムとPrologの解

答の結果を色々テストで突合せてみても同じなのでこれ

で良いんだとは思う。

残りの問題:'(59 60 63 66 80-94 96-99) 解答状況 62/84

P58

解答
N=57の時に線対称の形状になる組み合わせの数
(length (sym-cbal-trees 57))
=> 256

Nが偶数だとどうなるか。
=> 線対称の木は生成されない。

;; Common Lisp
;; -----------------------------------------------------------------------------
(defpackage l99 (:use #:cl))

(load "p55") ;cbal-tree
(load "p57") ;symmetric

(in-package :l99)

(defun sym-cbal-tree (n)
  (reduce (lambda (res tr) (if (symmetric tr) `(,tr ,@res) res))
	  (cbal-tree n)
	  :initial-value () ))

2007-09-10

L-99 (55)

| 22:42 | L-99 (55) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (55) - わだばLisperになる

L-99 P55に挑戦 - L-99:Ninety-Nine Lisp Problems

実に4ヶ月ぶり。以前、12時間考えてどうにも分からな

かった問題を思い出して再挑戦。

しかし、久しぶりに考えてみたら案外あっさりできた。

難しく考え過ぎてたらしい。

残りの問題:'(58-60 63 66 80-94 96-99) 解答状況 61/84

P55

解答
;; Common Lisp
;; -----------------------------------------------------------------------------
(defpackage l99 (:use #:cl))

(in-package :l99)

(defun cbal-tree (n)
  (if (zerop n)
      '(())
      (if (>= 1 n)
	  '((x () () ))
	  (reduce (lambda (res x) 
		    (let ((tree `(x ,@x)))
		      (if (cbal-tree-p tree)
			  `(,tree ,@res)
			  res)))
		  (let ((half (/ (1- n) 2))) ;balanced
		    (if (zerop (mod half 1))
			(comb2 (cbal-tree half)
			       (cbal-tree half))
			(let ((g (ceiling (/ (1- n) 2))) ;greater
			      (l (truncate (/ (1- n) 2)))) ;less
			`(,@(comb2 (cbal-tree l)
				   (cbal-tree g))
			    ,@(comb2 (cbal-tree g)
				     (cbal-tree l))))))
		  :initial-value () ))))

(defun cbal-tree-p (tree)
  (>= 1 (abs (- (count-leaf (cadr tree))
		(count-leaf (caddr tree))))))

(defun count-leaf (tree)
  (if tree
      (+ 1 (count-leaf (cadr tree)) (count-leaf (caddr tree)))
      0))

(defun comb2 (xs ys)
  (mapcan (lambda (y)
	    (mapcar (lambda (x) `(,x ,y)) xs))
	  ys))
テスト
(defun ppt (tree) (mapc #'print tree))

(ppt (cbal-tree 4))
=>
 (X (X NIL (X NIL NIL)) (X NIL NIL)) 
 (X (X (X NIL NIL) NIL) (X NIL NIL)) 
 (X (X NIL NIL) (X NIL (X NIL NIL))) 
 (X (X NIL NIL) (X (X NIL NIL) NIL))

2007-05-29

L-99 (27)

| 15:04 | L-99 (27) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (27) - わだばLisperになる

L-99 P27に挑戦 - L-99:Ninety-Nine Lisp Problems

久々の更新。先に進めないので、後回しにしていたP27に挑戦。

残りの問題:'(55 58-60 63 66 80-94 96-99)

P27

解答
;; Lisp Machine Lisp
;; -----------------------------------------------------------------------------
(defun group (lst pat)
  (group-rpat lst (reverse pat)))

(defun group-rpat (lst pat)
  (if (> (apply #'+ pat) (length lst))
      (error "foo!")
    (cond ((null pat) () )
	  ((= (length lst) (car pat)) `(,lst))
	  ((= 1 (length pat)) 
	   (sep2 lst (car pat)))
	  ('t (sep2s (group-rpat lst (cdr pat)) (car pat))))))

(defun sep2 (lst num)
  (let ((front (combination num lst)))
    (mapcar #'(lambda (item) 
		`(,item ,(setdiff lst item)))
	    front)))

(defun sep2s (lsts num)
  (do ((l lsts (cdr l))
       (retlst () ))
      ((null l) retlst)
    (setq retlst 
	  `(,@retlst 
	    ,@(mapcar #'(lambda (item)
			     (if (cadr item)
				 `(,@(butlast (car l)) ,(car item) ,(cadr item)) 
				 `(,@(butlast (car l)) ,(car item))))
		   (sep2 (car (last (car l))) num))))))

;; Utils (from Maclisp LSETS.LSP)
(defun y-x+z (y x z &aux y-x)
  (mapc #'(lambda (xx) (or (memq xx x) (push xx y-x))) y)
  (nreconc y-x z))

(defun setdiff (x y)
  (if (dolist (xx y)
	(let ((res (memq xx x)))
	  (and res (return xx))))
      (y-x+z x y () )
    x))

;; Common Lisp
;; -----------------------------------------------------------------------------
(defun group (lst pat)
  (group-rpat lst (reverse pat)))

(defun group-rpat (lst pat)
  (if (> (apply #'+ pat) (length lst))
      (error "foo!")
      (cond ((endp pat) '()	)
	    ((= (length lst) (car pat)) `(,lst))
	    ((= 1 (length pat)) 
	     (sep2 lst (car pat)))
	    ('t (sep2s (group-rpat lst (cdr pat)) (car pat))))))

(defun sep2 (lst num)
  (let ((front (combination num lst)))
    (map 'list #'(lambda (item) 
		   `(,item ,(set-difference lst item)))
	 front)))

(defun sep2s (lsts num)
  (do ((l lsts (cdr l))
       (retlst '()))
      ((endp l) retlst)
    (setq retlst 
	  `(,@retlst 
	    ,@(map 'list #'(lambda (item)
			     (if (cadr item)
				 `(,@(butlast (car l)) ,(car item) ,(cadr item)) 
				 `(,@(butlast (car l)) ,(car item))))
		   (sep2 (car (last (car l))) num))))))

;; Scheme
;; -----------------------------------------------------------------------------
(define (group lst pat)
  (group-rpat lst (reverse pat)))

(define (group-rpat lst pat)
  (if (> (apply + pat) (length lst))
      '()
      (cond ((null? pat) 
	     '() )
	    ((= (length lst) (car pat))
	     `(,lst))
	    ((= 1 (length pat)) 
	     (sep2 lst (car pat)))
	    (else 
	     (sep2s (group-rpat lst (cdr pat)) (car pat))))))

(define (sep2 lst num)
  (if (> num (length lst))
      '()
      (let ((front (combination num lst)))
	(map  (lambda (item) 
		`(,item ,(lset-difference eq? lst item)))
	      front))))

(define (sep2s lsts num)
  (let frob ((l lsts)
	     (retlst '() ))
    (if (null? l)
	retlst
	(frob (cdr l)
	      `(,@retlst 
		,@(map (lambda (item)
			 `(,@(drop-right (car l) 1) ,@(remove null? item)))
		       (sep2 (last (car l)) num)))))))

2007-05-19

L-99 (80) (4)

| 00:02 | L-99 (80) (4) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (80) (4) - わだばLisperになる

L-99 P80に挑戦 - L-99:Ninety-Nine Lisp Problems

P80の続き。Scheme版。

もう何が何だか良く分からないけど、これでP80も落着

としよう!

SRFI-42の内包表記とか使ってみようと思ったりもした

んだけども。

解答
;; Scheme
;; -----------------------------------------------------------------------------
;; utility
(define (flatten lst)
  (cond ((null? lst) '() )
	((not (pair? lst)) `(,lst))
	(else `(,@(flatten (car lst))
		,@(flatten (cdr lst))))))

(define (sort-by-symbol-name lst pos-fn)
  (sort lst
	(lambda (a b)
	  (string<? (symbol->string (pos-fn a)) (symbol->string (pos-fn b))))))

;; -----------------------------------------------------------------------------
;; Graph Term
;; 1)
(define (graph-term->edge-clause expr)
  (cadr expr))

;; 2) DIRECTED
(define graph-term->arc-clause/directed graph-term->edge-clause)

;; 3) LABELLED
(define graph-term->arc-clause/labelled graph-term->edge-clause)

;; 1)
(define (edge-clause->graph-term expr)
  `(,(sort-by-symbol-name
      (delete-duplicates
       (fold append '() expr))
      identity)
    ,expr))

;; 2) DIRECTED
(define arc-clause->graph-term/directed arc-clause->graph-term/labelled)

;; 3) LABELLED
(define (arc-clause->graph-term/labelled expr)
  `(,(sort-by-symbol-name
      (delete-duplicates
       (fold (lambda (item retlst) `(,@(drop-right item 1) ,@retlst))
	     '() expr))
      identity)
    ,expr))

;; -----------------------------------------------------------------------------
;; Adjacency List
;; 1)
(define (graph-term->adjacency-list expr)
  `(,@(map (lambda (item)
	     `(,item 
	       ,(remove null?
			(delete-duplicates 
			 (flatten 
			  (map (lambda (lst)
				 (remove (cut eq? item <>)
					 (if (memq item lst)
					     lst
					     '() )))
			       (cadr expr)))))))
	   (car expr))))

;; 2) DIRECTED
(define (graph-term->adjacency-list/directed expr)
  (map (lambda (item) `(,item ,(get-direction item (cadr expr))))
       (car expr)))

(define (get-direction from dist-lst)
  (fold (lambda (item retlst)
	  (if (eq? from (car item))
	      `(,@retlst ,(cadr item))
	      retlst))
	'() dist-lst))

;; 3) LABELLED
(define (graph-term->adjacency-list/labelled expr)
  (map (lambda (item)
	 `(,item ,(get-direction/labelled item (cadr expr))))
       (car expr)))
                      
(define (get-direction/labelled from dist-lst)
  (fold (lambda (item retlst)
	  (if (eq? from (car item))
	      `(,@retlst (,(cadr item) ,(caddr item)))
	      retlst))
	'() dist-lst))

;; 1)
(define (adjacency-list->graph-term expr)
  `(,(map car expr)
    ,(sort-by-symbol-name
      (delete-duplicates
       (fold (lambda (item retlst)
	       `(,@retlst 
		 ,@(map (lambda (j)
			  (sort-by-symbol-name `(,(car item) ,j) identity))
			(cadr item))))
	     '() expr))
      car)))

;; 2) DIRECTED
(define adjacency-list->graph-term/directed adjacency-list->graph-term)

;; 3) LEBELLED
(define (adjacency-list->graph-term/labelled expr)
  `(,(map car expr)
    ,(fold (lambda (item retlst)
                 `(,@retlst ,@(fold (lambda (num ret)
                                          (if (not (null? num))
                                              `(,@ret (,(car item) ,@num))
					      ret))
                                      '() (cadr item))))
             '() expr)))

;; -----------------------------------------------------------------------------
;; Human Friendly

;; 1)
(define (graph-term->human-friendly expr)
  (graph-term->human-friendly-aux expr "-"))

(define (graph-term->human-friendly-aux expr separater)
  (sort `(,@(map (lambda (item)
		   (string-append (symbol->string (car item)) 
				  separater 
				  (symbol->string (cadr item))))
		 (cadr expr))
	  ,@(map symbol->string
		 (lset-difference eq? (car expr) (flatten (cadr expr)))))
	string<?))

;; 2) DIRECTED
(define (graph-term->human-friendly/directed expr)
  (graph-term->human-friendly-aux expr ">"))

;; 3) LABELLED
(define (graph-term->human-friendly/labelled expr)
  (sort `(,@(map (lambda (item)
		   (match-let (((a b c) item))
			      (format #f "~A>~A/~A" a b c)))
		 (cadr expr))
	  ,@(map symbol->string
		 (lset-difference eq? (car expr) (flatten (cadr expr)))))
	string<?))

;; 1)
(define (human-friendly->graph-term expr)
  (human-friendly->graph-term-aux expr string-split/-))

(define (human-friendly->graph-term-aux expr split-fn)
  (let ((item-list 
	 (map (lambda (item)
		(if (null? (cdr item))
		    (string->symbol (car item))
		    `(,(string->symbol (car item)) 
		      ,(string->symbol (cadr item)))))
	      (split-fn expr))))
    `(,(delete-duplicates (flatten item-list)) 
      ,(remove (lambda (i) (not (pair? i))) item-list))))

(define (string-split/- strlst)
  (map (lambda (item) (string-split item #\-))
       strlst))

;; 2) DIRECTED
(define (human-friendly->graph-term/directed expr)
  (human-friendly->graph-term-aux expr string-split/>))

(define (string-split/> strlst)
  (map (lambda (item) (string-split item #\>))
       strlst))

;; 3) LABELLED
(define (human-friendly->graph-term/labelled expr)
  (let ((item-list 
	 (map (lambda (item)
		(if (null? (cdr item))
		    (string->symbol (car item))
		    (match-let (((from to label) item))
			       `(,(string->symbol from)
				 ,(string->symbol to)
				 ,(string->number label)))))
	      (string-split/labelled expr))))
    `(,(delete-duplicates
	(fold (lambda (item retlst)
		(if (pair? item) 
		    `(,@retlst ,@(drop-right item 1) )
		    `(,@retlst ,item)))
	      '() item-list))
      ,(remove (lambda (item) (not (pair? item))) item-list))))

(define (string-split/labelled strlst)
  (map (lambda (str)
	 (if (string-scan str #\/)
	     (match-let (((from to-label) (string-split str #\>)))
			(match-let (((to label) (string-split to-label #\/)))
				   `(,from ,to ,label)))
	     `(,str)))
       strlst))
;

2007-05-17

L-99 (80) (3)

| 22:10 | L-99 (80) (3) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (80) (3) - わだばLisperになる

L-99 P80に挑戦 - L-99:Ninety-Nine Lisp Problems

P80の続き。Lisp Machine Lisp版。

使ってるLisp Machine Lispのバージョンの違いについ

て気になって色々寄り道してしまい、なかなか完成せず。

その寄り道で、Lisp関数の歴史について深追いしてみた。

なかなか面白いので、年表的にまとめてみた。

reduceとか、set-differenceなどは、後期のLisp

Machine Lispにも存在するらしい。しかし、後期は

Common Lispとかなり混ざってしまっていて、Lisp

Machine Lispが起源なのかは良く分からない。

自分が使ってるCADR System 78.48は、Lisp Machine

Manualで言うと、第4版より前のもののようなので、色々

な関数が存在していない様子。

解答
;; Lisp Machine Lisp
;; -----------------------------------------------------------------------------
;;; utility

(defun flatten (list)
  (flatten-aux list '() ))

(defun flatten-aux (list acc)
  (cond ((null list) acc)
	((listp (car list)) 
	 (flatten-aux (cdr list) (append acc (flatten-aux (car list) '()))))
	(t 
	 (flatten-aux (cdr list) (append acc (list (car list))))))))

(defun -set-difference (lst1 lst2)
  (let ((retlst '()))
    (dolist (item lst1)
      (or (memq item lst2)
	  (setq retlst (cons item retlst))))
    (nreverse retlst)))

(defun -remove-duplicates (lst)
  (do ((l lst (cdr l))
       (retlst '() ))
      ((null l) (nreverse retlst))
    (or (member (car l) retlst)
	(setq retlst (cons (car l) retlst)))))

;; -----------------------------------------------------------------------------
;; graph-term <=> edge-clause

;; 1)
(defun graph-term->edge-clause (expr)
  (cadr expr))

;; 2) DIRECTED
(deff graph-term->arc-clause//directed 'graph-term->edge-clause)

;; 3) LABELLED
(deff graph-term->arc-clause//labelled 'graph-term->edge-clause)

;; 1)
(defun edge-clause->graph-term (expr)
  `(,(sort
       (-remove-duplicates
	(let ((retlst '()))
	  (dolist (item expr)
	    (setq retlst (append item retlst)))
	  (nreverse retlst)))
      #'(lambda(a b) (string-lessp (string a) (string b))))
    ,expr))

;; 2) DIRECTED
(deff arc-clause->graph-term//directed 'arc-clause->graph-term//labelled)

;; 3) LABELLED
(defun arc-clause->graph-term//labelled (expr)
  `(,(sort 
      (-remove-duplicates
	(let ((retlst '()))
	  (dolist (item expr)
	    (setq retlst `(,@(butlast item) ,@retlst)))
	  (nreverse retlst)))
      #'(lambda(a b) (string-lessp (string a) (string b))))
    ,expr))

;; -----------------------------------------------------------------------------
;; graph-term <=> adjacency-list

;; 1)
(defun graph-term->adjacency-list (expr)
  `(,@(mapcar #'(lambda (item)
		  `(,item 
		    ,(remove nil
			     (-remove-duplicates 
			      (flatten 
			       (mapcar #'(lambda (lst)
					   (remove item
						   (if (member item lst)
						       lst
						       nil)))
				       (cadr expr)))))))
	      (car expr))))

;; 2) DIRECTED
(defun graph-term->adjacency-list//directed (expr)
  (mapcar #'(lambda (item) `(,item ,(get-direction item (cadr expr))))
          (car expr)))

(defun get-direction (from dist-lst)
  (let ((retlst '()))
    (dolist (item dist-lst)
      (and (eq from (car item))
	   (setq retlst `(,@retlst ,(cadr item)))))
    (nreverse retlst)))

;; 3) LABELLED
(defun graph-term->adjacency-list//labelled (expr)
  (mapcar #'(lambda (item)
              `(,item ,(get-direction//labelled item (cadr expr))))
          (car expr)))
                       
(defun get-direction//labelled (from dist-lst)
  (let ((retlst '()))
    (dolist (item dist-lst)
      (and (eq from (car item))
	   (setq retlst `(,@retlst (,(cadr item) ,(caddr item))))))
    (nreverse retlst)))

;; 1)
(defun adjacency-list->graph-term (expr)
  `(,(mapcar #'car expr)
    ,(sort
       (-remove-duplicates
	 (let ((retlst '()))
	   (dolist (item expr)
	     (setq retlst 
		   `(,@retlst 
		     ,@(mapcar 
			 #'(lambda (j)
			     (sort `(,(car item) ,j)
				   #'(lambda(a b)
				       (string-lessp (string a) (string b)))))
			 (cadr item)))))
	   (nreverse retlst)))
       #'(lambda(a b) (string-lessp (string (car a)) (string (car b)))))))

;; 2) DIRECTED
(defun adjacency-list->graph-term//directed (expr)
  `(,(mapcar #'car expr)
    ,(let ((retlst '()))
       (dolist (item expr)
	 (setq retlst 
	       (if item
		   `(,@retlst ,@(mapcar #'(lambda (i) `(,(car item) ,i)) 
					(cadr item))))))
       retlst)))

;; 3) LEBELLED
(defun adjacency-list->graph-term//labelled (expr)
  `(,(mapcar #'car expr)
    ,(let ((retlst '()))
       (dolist (item expr)
	 (setq retlst
	       `(,@retlst 
		 ,@(let ((ret '()))
		     (dolist (num (cadr item))
		       (setq ret (if num
				     `(,@ret (,(car item) ,@num))
				   ret)))
		     ret))))
       retlst)))

;; -----------------------------------------------------------------------------
;; graph-term <=> human-friendly

;; 1)
(defun graph-term->human-friendly (expr)
  (sort `(,@(mapcar #'(lambda (item)
			(string-append (string (car item)) "-" (string (cadr item))))
		    (cadr expr))
	    ,@(mapcar #'string
		      (-set-difference (car expr) (flatten (cadr expr)))))
	#'string-lessp))

;; 2) DIRECTED
(defun graph-term->human-friendly//directed (expr)
  (sort `(,@(mapcar #'(lambda (item) 
                        (format nil "~A>~A" (car item) (cadr item)))
		    (cadr expr))
          ,@(mapcar #'string
                    (-set-difference (car expr) (flatten (cadr expr)))))
	#'string-lessp))

;; 3) LABELLED
(defun graph-term->human-friendly//labelled (expr)
  (sort `(,@(mapcar #'(lambda (item) (format nil "~{~A>~A//~A~}" item))
		    (cadr expr))
          ,@(mapcar #'string
                    (-set-difference (car expr) (flatten (cadr expr)))))
	#'string-lessp))

;; 1)
(defun human-friendly->graph-term (expr)
  (human-friendly->graph-term-aux expr #'string-split//-))

(defun human-friendly->graph-term-aux (expr split-fn)
  (let ((item-list (mapcar #'(lambda (item)
			       (if (listp item)
				   `(,(read-from-string (car item)) 
				     ,(read-from-string (cadr item)))
				 (read-from-string item)))
			   (funcall split-fn expr))))
    `(,(-remove-duplicates (flatten item-list)) ,(rem-if-not #'listp item-list))))

(defun string-split//- (strlst)
  (mapcar #'(lambda (item)
	      (let ((pos (string-search #/- item)))
		(if pos
		    `(,(substring item 0 pos)
		      ,(substring item (1+ pos)))
		  item)))
	  strlst))

;; 2) DIRECTED
(defun human-friendly->graph-term//directed (expr)
  (human-friendly->graph-term-aux expr #'string-split//>))

(defun string-split//> (strlst)
  (mapcar #'(lambda (item)
	      (let ((pos (string-search #/> item)))
		(if pos
		    `(,(substring item 0 pos)
		      ,(substring item (1+ pos)))
		  item)))
	  strlst))

;; 3) LABELLED
(defun human-friendly->graph-term//labelled (expr)
  (let ((item-list (mapcar #'(lambda (item)
			       (if (listp item)
				   (mapcar #'read-from-string item)
				 (read-from-string item)))
                             (string-split//labelled expr))))
    `(,(-remove-duplicates 
	 (let ((retlst '()))
	   (dolist (item item-list)
	     (setq retlst `(,@retlst ,@(if (listp item) 
					   (butlast item) 
					 `(,item)))))
	   retlst))
      ,(rem-if-not #'listp item-list))))

(defun string-split//labelled (strlst)
  (mapcar #'(lambda (item)
	      (let ((>pos (string-search #/> item))
		    (//pos (string-search #// item)))
		(if >pos 
		    `(,(substring item 0 >pos)
		      ,(substring item (1+ >pos) //pos)
		      ,(substring item (1+ //pos)))
		  item)))
	  strlst))

2007-05-14

L-99 (80) (2)

| 21:50 | L-99 (80) (2) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (80) (2) - わだばLisperになる

L-99 P80に挑戦 - L-99:Ninety-Nine Lisp Problems

P80の続き。だいぶ重複も多い気がするし、まとめるべ

きなんだろうけども、まとめる気力がないので、とりあ

えず、このままで(ノ´∀`*)

今回は、Common Lisp版の有向グラフ版と、名札付き有

向グラフ版。

Lisp Machine LispとScheme版は、また後で。

解答
;; Common Lisp
(load ./flatten)

;; -----------------------------------------------------------------------------
;; DIRECTED
;; graph-term <=> arc-clause
(defun graph-term->arc-clause/directed (expr)
  (cadr expr))

(defun arc-clause->graph-term/directed (expr)
  `(,(sort
      (delete-duplicates
       (reduce #'xappend
               expr :initial-value '() ))
      #'(lambda(a b) (string< (string a) (string b))))
    ,expr))

(defun xappend (lst1 lst2)
  (append lst2 lst1))

;; -----------------------------------------------------------------------------
;; adjacency-list <=> graph-term
(defun adjacency-list->graph-term/directed (expr)
  `(,(mapcar #'car expr)
    ,(reduce #'(lambda (retlst item)
                 (if item
                     `(,@retlst ,@(mapcar #'(lambda (i) `(,(car item) ,i)) 
                                          (cadr item)))
                   retlst))
             expr :initial-value '() )))

(defun graph-term->adjacency-list/directed (expr)
  (mapcar #'(lambda (item) `(,item ,(get-direction item (cadr expr))))
          (car expr)))

(defun get-direction (from dist-lst)
  (reduce #'(lambda (retlst item)
              (if (eql from (car item))
                  `(,@retlst ,(cadr item))
                retlst))
          dist-lst :initial-value '() ))

;; -----------------------------------------------------------------------------
;; directed-graph-term <=> human-friendly
(defun graph-term->human-friendly/directed (expr)
  (sort `(,@(mapcar #'(lambda (item) 
                        (format nil "~A>~A" (car item) (cadr item)))
		    (cadr expr))
          ,@(mapcar #'string
                    (set-difference (car expr) (flatten (cadr expr)))))
	#'string<))

(defun human-friendly->graph-term/directed (expr)
  (flet ((splitter (strlst)
           (mapcar #'(lambda (item)
                       (let ((pos (position #\> (coerce item 'list))))
                         (if pos
                             `(,(subseq item 0 pos)
                               ,(subseq item (1+ pos)))
                           item)))
                   strlst)))
    (let ((item-list (mapcar #'(lambda (item)
                                 (if (listp item)
                                     (mapcar #'read-from-string item)
                                   (read-from-string item)))
                             (splitter expr))))
      `(,(delete-duplicates (flatten item-list)) 
        ,(delete-if-not #'listp item-list)))))

;; -----------------------------------------------------------------------------
;; LABELLED
;; graph-term <=>arc-clause
(defun graph-term->arc-clause/labelled (expr)
  (cadr expr))

(defun arc-clause->graph-term/labelled (expr)
  `(,(sort 
      (delete-duplicates
       (reduce #'(lambda (ret item) `(,@(butlast item) ,@ret))
               expr :initial-value '() ))
      #'(lambda(a b) (string< (string a) (string b))))
    ,expr))

;; -----------------------------------------------------------------------------
;; adjacency-list <=> graph-term/labelled
(defun adjacency-list->graph-term/labelled (expr)
  `(,(mapcar #'car expr)
    ,(reduce #'(lambda (retlst item)
                 `(,@retlst ,@(reduce #'(lambda (ret num)
                                          (if num
                                              `(,@ret (,(car item) ,@num))
                                            ret))
                                      (cadr item) :initial-value '() )))
             expr :initial-value '() )))

(defun graph-term->adjacency-list/labelled (expr)
  (mapcar #'(lambda (item)
              `(,item ,(get-direction/labelled item (cadr expr))))
          (car expr)))
                       
(defun get-direction/labelled (from dist-lst)
  (reduce #'(lambda (retlst item)
              (if (eql from (car item))
                  `(,@retlst (,(cadr item) ,(caddr item)))
                retlst))
          dist-lst :initial-value '() ))

;; -----------------------------------------------------------------------------
;; graph-term <=> human-friendly
(defun graph-term->human-friendly/labelled (expr)
  (sort `(,@(mapcar #'(lambda (item) (format nil "~{~A>~A/~A~}" item))
		    (cadr expr))
          ,@(mapcar #'string
                    (set-difference (car expr) (flatten (cadr expr)))))
	#'string<))

(defun human-friendly->graph-term/labelled (expr)
  (labels ((splitter (strlst)
             (mapcar #'(lambda (item)
                         (let ((>pos (position #\> (coerce item 'list)))
                               (/pos (position #\/ (coerce item 'list))))
                           (if >pos 
                               `(,(subseq item 0 >pos)
                                 ,(subseq item (1+ >pos) /pos)
                                 ,(subseq item (1+ /pos)))
                             item)))
                     strlst)))
    (let ((item-list (mapcar #'(lambda (item)
                                 (if (listp item)
                                     (mapcar #'read-from-string item)
                                   (read-from-string item)))
                             (splitter expr))))
      `(,(delete-duplicates 
          (reduce #'(lambda (retlst item)
                      `(,@retlst ,@(if (listp item) (butlast item) `(,item))))
                  item-list :initial-value '() )) 
        ,(delete-if-not #'listp item-list)))))

2007-05-11

L-99 (80)

| 19:12 | L-99 (80) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (80) - わだばLisperになる

L-99 P80に挑戦 - L-99:Ninety-Nine Lisp Problems

|-`)どういう訳かド鬱になってきた。なんにもしたくな

い。

きっと引きこもりっきりで体を動かしてない所為だと推

測。

軽快な運動をしつつプログラミングできたら結構良い感

じなんじゃないかと思うんだけど、どうなんだろう。

そして問題もややこしくなってきて、さらにやる気が出

ないが、しかし粘着に遂行するぞ。

80番台は、グラフ(ネットワーク)の問題。

今回のお題は、グラフを色々な方式で表現し、それを相

互に変換してみようという内容。

形式は、基本的に

1) edge-clause形式

2) graph-term形式

3) adjacency-list形式

4) human-friendly形式

と4つあり、これらに

1) 無向グラフ版

2) 有向グラフ版

3) 名札つき有向グラフ版

がある。

とりあえず、量が多いので少しずつ解答して行くことにした。

今回は、Common Lisp版の無向グラフ版。

残りの問題:'(27 55 58-60 63 66 80-94 96-99)

P80

解答
;; Common Lisp
(load ./flatten)

(defun graph-term->edge-clause (expr)
  (cadr expr))

(defun edge-clause->graph-term (expr)
  `(,(sort (delete-duplicates
	 (reduce #'(lambda (ret item) `(,(car item) ,(cadr item) ,@ret))
		 expr :initial-value '() ))
	#'(lambda(a b)
	    (string< (string a) (string b))))
     ,expr))

(defun graph-term->adjacency-list (expr)
  `(,@(mapcar #'(lambda (item)
		  `(,item 
		    ,(delete nil
			     (delete-duplicates 
			      (flatten 
			       (mapcar #'(lambda (lst)
					   (delete item
						   (if (member item lst)
						       lst
						       nil)))
				       (cadr expr)))))))
	      (car expr))))

(defun adjacency-list->graph-term (expr)
  `(,(mapcar #'car expr)
     ,(sort
       (delete-duplicates
	(reduce #'(lambda (retlst i)		
		    `(,@retlst ,@(mapcar #'(lambda (j)
					     (sort `(,(car i) ,j)
						   #'(lambda(a b)
						       (string< (string a) (string b)))))
					 (cadr i))))
		expr :initial-value '() ) 
	:test #'equal) 
       #'(lambda(a b) (string< (string (car a)) (string (car b)))))))

(defun graph-term->human-friendly (expr)
  (sort `(,@(mapcar #'(lambda (item)
			(concatenate 'string (string (car item)) "-" (string (cadr item))))
		    (cadr expr))
	    ,@(mapcar #'string
		      (set-difference (car expr) (flatten (cadr expr)))))
	#'string<))

(defun human-friendly->graph-term (expr)
  (flet ((string-split/- (strlst)
	   (mapcar #'(lambda (item)
		       (let ((pos (position #\- (coerce item 'list))))
			 (if pos
			     `(,(subseq item 0 pos)
				,(subseq item (1+ pos)))
			     item)))
		   strlst)))
    (let ((item-list (mapcar #'(lambda (item)
				 (if (listp item)
				     `(,(read-from-string (car item)) 
					,(read-from-string (cadr item)))
				     (read-from-string item)))
			     (string-split/- expr))))
      `(,(delete-duplicates (flatten item-list)) ,(delete-if-not #'listp item-list)))))

2007-05-07

L-99 (68)

| 09:02 | L-99 (68) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (68) - わだばLisperになる

L-99 P68に挑戦 - L-99:Ninety-Nine Lisp Problems

だんだん解けそうなのがなくなってきてしまった。問題

が解けないと面白くないじゃないか。

今回のお題は、a)二分木を行きがけ順(preorder)と、通り

がけ順(in-order)の二通りの文字列表現にする。b)は意

図が良く分からない。c)はin-orderとpreorderの文字列

によって一意に構造が特定できるので、それから木構造

を生成する。d)はDifference listを使ってみる。

それと、同じノード名を使用した場合の動作についての

考察

bとdはいまいち良く分からないので、aとcを解答。

同じノード名を使用した場合、一意に構造が特定できな

いので、プログラムによって動作が異なってくると思う。

残りの問題:'(27 55 58-60 63 66 80-94 96-99)

P68

;; LISP Machine LISP
(load "string-join.lisp")

(defun preorder (tree)
  (string-join (preorder-aux tree)))

(defun preorder-aux (tree)
  (if tree
      `(,(string (car tree)) 
	,@(preorder-aux (cadr tree)) 
	,@(preorder-aux (caddr tree)))
    '("") ))

(defun inorder (tree)
  (string-join (inorder-aux tree)))

(defun inorder-aux (tree)
  (if tree
      `(,@(inorder-aux (cadr tree)) 
	,(string (car tree)) 
	,@(inorder-aux (caddr tree)))
    '("") ))

(defun snull (str)
  (if (and (stringp str) (string-equal str ""))
      ""
    nil))

(defun disassemble-tree-string (pre in)
  (if (or (snull pre) (snull in))
      ""
    (let* ((root (aref pre 0))
	   (left-in   (substring in  0 (string-search root in)))
	   (left-pre  (substring pre 1 (1+ (string-length left-in))))
	   (right-in  (substring in  (1+ (string-search root in))))
	   (right-pre (substring pre (1+ (string-length left-in)))))
      (values (string root) left-in left-pre right-in right-pre))))

(defun pre+in->tree (pre in)
  (if (or (snull pre) (snull in))
      '()
    (multiple-value-bind (root left-in left-pre right-in right-pre) 
	(disassemble-tree-string pre in)
      `(,(read-from-string root)
	,(pre+in->tree left-pre left-in)
	,(pre+in->tree right-pre right-in)))))

;; Common Lisp
(load "./string-join")

(defun preorder (tree)
  (labels ((frob (tree)
	     (if tree
		 `(,(string (car tree)) ,@(frob (cadr tree)) ,@(frob (caddr tree)))
		 '(""))))
    (string-join (frob tree))))

(defun inorder (tree)
  (labels ((frob (tree)
	     (if tree
		 `(,@(frob (cadr tree)) ,(string (car tree)) ,@(frob (caddr tree)))
		 '(""))))
    (string-join (frob tree))))

(defun snull (str)
  (if (and (stringp str) (string= str ""))
      ""
      nil))

(defun disassemble-tree-string (pre in)
  (if (or (snull pre) (snull in))
      ""
      (let* ((root (char pre 0))
	     (left-in   (subseq in  0 (position root in)))
	     (left-pre  (subseq pre 1 (1+ (length left-in))))
	     (right-in  (subseq in  (1+ (position root in))))
	     (right-pre (subseq pre (1+ (length left-in)))))
	(values (string root) left-in left-pre right-in right-pre))))

(defun pre+in->tree (pre in)
  (if (or (snull pre) (snull in))
      '()
      (multiple-value-bind (root left-in left-pre right-in right-pre) (disassemble-tree-string pre in)
	`(,(read-from-string root)
	   ,(pre+in->tree left-pre left-in)
	   ,(pre+in->tree right-pre right-in))))) 

;; Scheme
(define (preorder tree)
  (letrec ((frob 
	    (lambda (tree)
	      (if (null? tree)
		  '("")
		  `(,(symbol->string (car tree)) ,@(frob (cadr tree)) ,@(frob (caddr tree)))))))
    (string-join (frob tree) "")))

(define (inorder tree)
  (letrec ((frob 
	    (lambda (tree)
	      (if (null? tree)
		  '("")
		  `(,@(frob (cadr tree)) ,(symbol->string (car tree)) ,@(frob (caddr tree)))))))
    (string-join (frob tree) "")))

(define (disassemble-tree-string pre in)
  (if (or (string-null? pre) (string-null? in))
      ""
      (let* ((len       (string-length in))
	     (root      (substring pre 0 1))
	     (left-in   (substring in  0 (string-scan in root)))
	     (left-pre  (substring pre 1 (+ 1 (string-length left-in))))
	     (right-in  (substring in  (+ 1 (string-scan in root))   len))
	     (right-pre (substring pre (+ 1 (string-length left-in)) len)))
	(values root left-in left-pre right-in right-pre))))

(define (pre+in->tree pre in)
  (if (or (string-null? pre) (string-null? in))
      '()
      (receive (root left-in left-pre right-in right-pre) (disassemble-tree-string pre in)
	       `(,(string->symbol root)
		 ,(pre+in->tree left-pre left-in)
		 ,(pre+in->tree right-pre right-in)))))
;

2007-05-03

L-99 (69)

| 05:08 | L-99 (69) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (69) - わだばLisperになる

L-99 P69に挑戦 - L-99:Ninety-Nine Lisp Problems

難しいのは飛して今回は、P69に挑戦。

しかし、段々煮詰って来てしまい、どれもややこしくなっ

てきた。

またもや、文字列表現とリスト表現の変換がお題。

SchemeはもうすこしSchemeらしいスタイルにしたいとこ

ろ。

残りの問題:'(27 55 58-60 63 66 68 80-94 96-99)

P69

解答
;; LISP Machine LISP
(defun tree<=>dotstring (list-or-string)
  (if (stringp list-or-string)
      (dotstring->tree list-or-string)
    (tree->dotstring list-or-string)))

(defun tree->dotstring (tree)
  (string-join (tree->dotstring-aux tree)))

(defun tree->dotstring-aux (tree)
  (if tree
      `(,(string (car tree)) 
	,@(tree->dotstring-aux (cadr tree))
	,@(tree->dotstring-aux (caddr tree)))
    '(".")))

(defun string-join (strs &optional (delim ""))
  (if strs
      (let ((retstr (car strs)))
	(do ((s (cdr strs) (cdr s))
	     (retstr retstr (string-append retstr delim (car s))))
	    ((null s) retstr)))
    ""))

(defun dotstring->tree (str)
  (if (string-equal "" str)
      '()
    (let ((root (substring str 0 1)))
      (if (string-equal root ".")
	  '()
	(multiple-value-bind (l r) (tree-string>get-children str)
	  `(,(read-from-string root)
	    ,(dotstring->tree l)
	    ,(dotstring->tree r)))))))

(defun tree-string>get-boundary (str)
  (let ((point 1))
    (dotimes (i (1- (string-length str)))
      (if (not (string-equal "." (substring str i (1+ i))))
	  (setq point (+ 1 point))
	(setq point (- point 1)))
      (if (zerop point)
	  (return i)))))

(defun tree-string>get-children (str)
  (let ((rootless (substring str 1)))
    (values 
      (substring rootless 0 (1+ (tree-string>get-boundary rootless)))  
      (substring rootless (1+ (tree-string>get-boundary rootless))))))

;; Common Lisp
(defun tree<=>dotstring (list-or-string)
  (if (stringp list-or-string)
      (dotstring->tree list-or-string)
      (tree->dotstring list-or-string)))

(defun tree->dotstring (tree)
  (labels ((frob (tree)
	     (if tree
		 `(,(string (car tree)) ,@(frob (cadr tree)) ,@(frob (caddr tree)))
		 '("."))))
    (string-join (frob tree))))

(defun string-join (strs &optional (delim ""))
  (if strs
      (reduce #'(lambda (retstr s) (concatenate 'string retstr delim s))
	      strs)
      ""))

(defun dotstring->tree (str)
  (if (string= "" str)
      '()
      (let ((root (subseq str 0 1)))
	(if (string= root ".")
	    '()
	    (multiple-value-bind (l r) (tree-string>get-children str)
	      `(,(read-from-string (subseq str 0 1))
		 ,(dotstring->tree l)
		 ,(dotstring->tree r)))))))

(defun tree-string>get-boundary (str)
  (let ((point 1))
    (dotimes (i (1- (length str)))
      (if (string/= "." (subseq str i (1+ i)))
	  (setq point (+ 1 point))
	  (setq point (- point 1)))
      (if (zerop point)
	  (return i)))))

(defun tree-string>get-children (str)
  (let ((rootless (subseq str 1)))
    (values 
     (subseq rootless 0 (1+ (tree-string>get-boundary rootless)))  
     (subseq rootless (1+ (tree-string>get-boundary rootless)))))) 

;; Scheme
(define (tree<=>dotstring list-or-string)
  (if (string? list-or-string)
      (dotstring->tree list-or-string)
      (tree->dotstring list-or-string)))

(define (tree->dotstring tree)
  (letrec ((frob 
	    (lambda (tree)
	      (if (null? tree)
		  '(".")
		  `(,(symbol->string (car tree)) 
		    ,@(frob (cadr tree))
		    ,@(frob (caddr tree)))))))
    (string-join (frob tree) "")))

(define (dotstring->tree str)
  (if (string=? "" str)
      '()
      (let ((root (substring str 0 1)))
	(if (string=? root ".")
	    '()
	    (receive (l r) (tree-string>get-children str)
		     `(,(string->symbol root)
		       ,(dotstring->tree l)
		       ,(dotstring->tree r)))))))

(define (tree-string>get-boundary str)
  (let/cc exit
    (let ((point 1))
      (dotimes (i (- (string-length str) 1))
	       (if (not (string=? "." (substring str i (+ 1 i))))
		   (set! point (+ 1 point))
		   (set! point (- point 1)))
	       (if (zero? point)
		   (exit i))))))

(define (tree-string>get-children str)
  (let* ((len (string-length str))
	 (rootless (substring str 1 len))
	 (boundary (+ 1 (tree-string>get-boundary rootless))))
    (values 
     (substring rootless 0 boundary)
     (substring rootless boundary (- len 1)))))

2007-04-30

L-99 (95)

| 23:08 | L-99 (95) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (95) - わだばLisperになる

L-99 P95に挑戦 - L-99:Ninety-Nine Lisp Problems

あまりやる気が出ないので、簡単そうなのを探してみた

ところ、P95が簡単そうだったので、挑戦。

文字列処理は、Gaucheが充実しているので、そういう場

合、先にGaucheで実装してみるのが良いんじゃないかな

と思った春。

残りの問題:'(27 55 58-60 63 66 68 69 80-94 96-99)

P95

解答
;; LISP Machine LISP
(defun full-words (n)
  (let ((nstr (format nil "~a" n))
	(retstr ""))
    (mapc #'(lambda(x)
	      (setq retstr
		    (string-append
		      retstr
		      (selectq x
			(#/0 "zero")
			(#/1 "one")
			(#/2 "two")
			(#/3 "three")
			(#/4 "four")
			(#/5 "five")
			(#/6 "six")
			(#/7 "seven")
			(#/8 "eight")
			(#/9 "nine"))
		      "-")))
	  (let ((len (string-length nstr)))
	    (do ((i 0 (1+ i))
		 (retlst '()))
		((= i len) (nreverse retlst))
	      (push (aref nstr i) retlst))))
    (string-right-trim "-" retstr)))

;; Common Lisp
(defun full-words (n)
  (let ((nstr (format nil "~a" n))
	(retstr ""))
    (mapc #'(lambda(x)
	      (setq retstr
		    (concatenate 'string
				 retstr
				 (case x
				   (#\0 "zero")
				   (#\1 "one")
				   (#\2 "two")
				   (#\3 "three")
				   (#\4 "four")
				   (#\5 "five")
				   (#\6 "six")
				   (#\7 "seven")
				   (#\8 "eight")
				   (#\9 "nine"))
				 "-")))
	  (coerce nstr 'list))
    (string-right-trim "-" retstr)))

;; Scheme
(use srfi-13)

(define (full-words n)
  (string-join 
   (map (lambda (n)
	  (case n
	    ((#\0) "zero")
	    ((#\1) "one")
	    ((#\2) "two")
	    ((#\3) "three")
	    ((#\4) "four")
	    ((#\5) "five")
	    ((#\6) "six")
	    ((#\7) "seven")
	    ((#\8) "eight")
	    ((#\9) "nine")))
	(string->list (number->string n)))
   "-"))

2007-04-29

L-99 (67)

| 01:20 | L-99 (67) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (67) - わだばLisperになる

L-99 P67に挑戦 - L-99:Ninety-Nine Lisp Problems

66問目が難しいとのことなので、一つ飛して簡単そうな

のに着手したつもりが、難しかった。というかややこし

かった。というかなんでこんなに長くなってしまったの

か。

お題は、文字列で表現した二分木と、リスト表現の二分

木をお互いに変換できるような関数の作成。

問題はAとBとあるけれど、Difference listっていうの

は、Prologでの話のような香りなので、これは後で理解

できるようになったらまた検討することに。

文字列を扱う関数は、、Emacs Lisp、

Lisp Machine Lisp、Maclisp、Schemeで似てたり似てな

かったりでややこしい。

残りの問題:'(27 55 58-60 63 66 68 69 80-99)

P67

解答
;; LISP Machine LISP
(load "./leafp")

(defun find-region (str)
  (if (string-search-char #/( str)
      (let ((count 0)
	    (len (string-length str)))
	(do ((i 0 (1+ i))
	     (retlst '()))
	    ((= i len) (let ((reg (nreverse retlst)))
			 (values (car reg) (cadr reg))))
	  (let ((part (substring str i (1+ i))))
	    (cond 
	      ((and (string-equal "(" part) (zerop count)) (push i retlst) (incf count))
	      ((and (string-equal ")" part) (= 1 count))   (push i retlst) (decf count))
	      ((string-equal "(" part) (incf count))
	      ((string-equal ")" part) (decf count))
	      ('t nil)))))
    (values 0 0))))

(defun remove-parent (str)
  (multiple-value-bind (start end)
      (find-region str)
    (if (zerop end)
	str
      (substring str (1+ start) end))))

(defun get-children (str)
  (if (string-equal "" str)
      ""
    (let ((strip (remove-parent str)))
      (cond ((not (string-search-char #/, strip))
	     (values strip ""))
	    ((zerop (string-search-char #/, strip))
	     (values "" (substring strip 1)))
	    ('t 
	     (if (string-search-char #/( strip)
		 (multiple-value-bind (start end)
		     (find-region strip)
		   (values 
		     (substring strip 0 (1+ end))
		     (substring strip (+ 2 end))))
	       (values
		 (substring strip 0 (string-search-char #/, strip))
		 (substring strip (1+ (string-search-char #/, strip)))))))))))

(defun string->tree (str)
  (if (string-equal "" str)
      '()
    (let ((node (read-from-string str)))
      (multiple-value-bind (l r)
	  (get-children str)
	(if (string-search-char #/, str)
	    `(,node
	      ,(string->tree l)
	      ,(string->tree r))
	  `(,node () ()))))))

(defun tree->string-aux (tree)
  (if tree
      (if (leafp tree)
	  `(,(string (car tree)))
	`(,(string (car tree)) 
	  "("
	  ,@(tree->string-aux (cadr tree))
	  ","
	  ,@(tree->string-aux (caddr tree))
	  ")"))
    '() ))

(defun tree->string (tree)
  (let ((retstr ""))
    (mapc #'(lambda (str) 
	      (setq retstr (string-append retstr str)))
	  (tree->string-aux tree))
    retstr))

(defun tree<->string (tree-or-string)
  (if (stringp tree-or-string)
      (string->tree tree-or-string)
      (tree->string tree-or-string)))

;; Common Lisp
(load "./leafp")

(defun find-region (str)
  (if (find #\( str)
      (let ((count 0)
	    (len (length str)))
	(do ((i 0 (1+ i))
	     (retlst '()))
	    ((= i len) (let ((reg (nreverse retlst)))
			 (values (car reg) (cadr reg))))
	  (let ((part (subseq str i (1+ i))))
	    (cond 
	      ((and (string= "(" part) (zerop count)) (push i retlst) (incf count))
	      ((and (string= ")" part) (= 1 count))   (push i retlst) (decf count))
	      ((string= "(" part) (incf count))
	      ((string= ")" part) (decf count))
	      ('t nil)))))
      (values 0 0))))

(defun remove-parent (str)
  (multiple-value-bind (start end)
      (find-region str)
    (if (zerop end)
	str
	(subseq str (1+ start) end))))

(defun get-children (str)
  (if (string= "" str)
      ""
      (let ((strip (remove-parent str)))
	(cond ((not (find #\, strip))
	       (values strip ""))
	      ((zerop (position #\, strip))
	       (values "" (subseq strip 1)))
	      ('t 
	       (if (find #\( strip)
		   (multiple-value-bind (start end)
		       (find-region strip)
		     (declare (ignore start))
		     (values 
		      (subseq strip 0 (1+ end))
		      (subseq strip (+ 2 end))))
		   (values
		    (subseq strip 0 (position #\, strip))
		    (subseq strip (1+ (position #\, strip)))))))))))

(defun string->tree (str)
  (if (string= "" str)
      '()
      (let ((node (read-from-string str)))
	(multiple-value-bind (l r)
	    (get-children str)
	  (if (find #\, str)
	      `(,node
		,(string->tree l)
		,(string->tree r))
	      `(,node () ()))))))

(defun tree->string (tree)
  (labels ((frob (tree)
	     (if tree
		 (if (leafp tree)
		     `(,(string (car tree)))
		     `(,(string (car tree)) 
			"("
			,@(frob (cadr tree))
			","
			,@(frob (caddr tree))
			")"))
		 '() )))
    (map 'string #'(lambda (x) (char x 0))
	 (frob tree))))

(defun tree<->string (tree-or-string)
  (if (stringp tree-or-string)
      (string->tree tree-or-string)
      (tree->string tree-or-string)))

;; Scheme
(load "./leaf?.scm")
(use srfi-13)				;string-join

(define (find-region str)
  (if (string-scan str #\( )
      (let ((count 0)
	    (len (string-length str)))
	(do ((i 0 (+ 1 i))
	     (retlst '()))
	    ((= i len) (let ((reg (reverse retlst)))
			 (values (car reg) (cadr reg))))
	  (let ((part (substring str i (+ i 1))))
	    (cond 
	     ((and (string=? "(" part) (zero? count)) (push! retlst i) (inc! count))
	     ((and (string=? ")" part) (= 1 count))   (push! retlst i) (dec! count))
	     ((string=? "(" part) (inc! count))
	     ((string=? ")" part) (dec! count))))))
      (values 0 0)))

(define (remove-parent str)
  (receive (start end)
	   (find-region str)
	   (if (zero? end)
	       str
	       (substring str (+ 1 start) end))))

(define (get-children str)
  (if (string=? "" str)
      ""
      (let ((strip (remove-parent str)))
	(cond ((not (string-scan strip #\,))
	       (values strip ""))
	      ((zero? (string-scan strip #\,))
	       (values "" (substring strip 1 (string-length strip))))
	      ('t 
	       (if (string-scan strip #\( )
		   (receive (start end)
			    (find-region strip)
			    (values 
			     (substring strip 0 (+ 1 end))
			     (substring strip (+ 2 end) (string-length strip))))
		   (string-scan strip #\, 'both)))))))

(define (string->tree str)
  (if (string=? "" str)
      '()
      (let ((node (cond ((string-scan str #\( 'before) => string->symbol)
			(else (string->symbol str)))))
	(receive (l r)
		 (get-children str)
		 (if (string-scan str #\,)
		     `(,node
		       ,(string->tree l)
		       ,(string->tree r))
		     `(,node () ()))))))

(define (tree->string tree)
  (letrec ((frob
	    (lambda (tree)
	      (if (null? tree)
		  '()
		  (if (leaf? tree)
		      `(,(symbol->string (car tree)))
		      `(,(symbol->string (car tree)) 
			"("
			,@(frob (cadr tree))
			","
			,@(frob (caddr tree))
			")"))))))
    (string-join (frob tree) "")))

(define (tree<->string tree-or-string)
  (if (string? tree-or-string)
      (string->tree tree-or-string)
      (tree->string tree-or-string)))