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-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)))

2007-04-26

CADRでSICP 1.6

| 21:37 | CADRでSICP 1.6 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRでSICP 1.6 - わだばLisperになる

CADRでSICP Exercise 1.6.に挑戦 - Structure and Interpretation of Computer Programs

Exercise 1.6
ifが特殊形式である必要性について

(defun new-if (predicate then-clause else-clause)
  (cond (predicate then-clause)
	(T else-clause)))
のように新しいifを定義する。
これが、
(defun sqrt-iter (guess x)
  (new-if (good-enough-p guess x)
          guess
	  (sqrt-iter (improve guess x)
	             x)))
のように使われた場合、どのように動くかを考察せよ、
というような問題。
解答
特殊形式でないと、then部、else部ともに評価を終えた
後で、分岐を評価しようとするので、自分を呼び出す再
帰が使われている場合、無限ループになってしまう。
そして全然質問とは関係ないが、ずっと解答と書いてい
たつもりが、回答となっていたことにはたと気付いたの
で全部直した。

自分のための理解補助コード:
(defun foo (x)
  (if (zerop x)
      'zero!
    (princ "foo!")))

(foo 0)
-> ZERO!

(defun bar (x)
  (new-if (zerop x)
	  'zero!
	  (princ "foo!")))

(bar 0)
->ZERO!
と共にfoo!もプリントされる。

2007-04-25

CADRでSICP 1.5

| 20:03 | CADRでSICP 1.5 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRでSICP 1.5 - わだばLisperになる

CADRでSICP Exercise 1.5.に挑戦 - Structure and Interpretation of Computer Programs

Exercise 1.5
(defun p ()
  (p))

(defun test (x y)
  (if (= x 0)
      0
    (if (functionp y)
	(funcall y)
      y)))
とした場合、
(test 0 #'p)
の評価が正規順序の評価と、作用的順序の評価でどう違っ
てくるかを説明せよ。
解答
正規順序だと、(p)が実行されることになるので、無限
ループになるんではなかろうか。ということで、(p)の
評価が終らず結果が出せない。
ちなみにCADRでは、PDL Overflowになる。
作用的順序だと、(p)は評価する必要がないので0が返さ
れ終了する。

CADRでSICP 1.4

| 20:01 | CADRでSICP 1.4 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRでSICP 1.4 - わだばLisperになる

CADRでSICP Exercise 1.4.に挑戦 - Structure and Interpretation of Computer Programs

Exercise 1.4
演算子が合成式でも評価モデルが使えるかを観察せよ。
Scheme:
(define (a-plus-abs-b a b)
  ((if (> b 0) + -) a b))

解答
Lisp Machine Lispというか、Lisp-2だと
(defun a-plus-abs-b (a b)
  (funcall (if (> b 0) #'+ #'-) a b))
となると思う。
(a-plus-abs-b 3 -3)
-> 6.
にはなるけど、これは演算子が合成式ってことになりま
せんわよね。

L-99 (65)

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

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

  1   5   10   15   20   25
1       ,-------n-------,
2   ,---k---,       ,---u
3 ,-c-,     m       p-,
4 a  ,5,              q
5    d g

のような二分木の図を良く眺めて法則性を発見し、その

法則に従って位置情報をノードにした二分木を作成する

のがお題。

作ってる自分でも良く分からないでき上がり。

Lisp Machine Lispにはlabelsとかfletがないのだけれ

ど、どういう風に書くのが定石なのだろうか。とりあえ

ず、補助関数ってことにしてみたけれど。

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

P65

解答
;; LISP Machine LISP
(defun tree-depth (tree)
  (if tree
      (tree-depth-aux tree 0)
    0))

(defun tree-depth-aux (tree level)
  (let ((left (cadr tree))
	(right (caddr tree)))
    (if (and (null left) (null right))
	level
      (max (tree-depth-aux left (1+ level))
	   (tree-depth-aux right (1+ level))))))

(defun depth-of-most-left-node (tree)
  (if tree
      (depth-of-most-left-node-aux tree 0)
      0))

(defun depth-of-most-left-node-aux (tree level)
  (let ((left (cadr tree)))
    (if left
	(depth-of-most-left-node-aux left (1+ level))
      level)))

(defun layout-binary-tree-2 (tree)
  (let ((depth (tree-depth tree)))
    (layout-binary-tree-2-aux 
      tree 
      (1+ (- (expt 2 (tree-depth tree))
	     (expt 2 (- (tree-depth tree) (depth-of-most-left-node tree)))))
      depth 1)))

(defun layout-binary-tree-2-aux (tree pos depth level)
  (let ((left (cadr tree))
	(right (caddr tree)))
    (cond ((null tree) '() )
	  ('T
	   (let ((offset (expt 2 (1- depth))))
	     `((,pos . ,level)
	       ,(layout-binary-tree-2-aux left  (- pos offset) (1- depth) (1+ level))
	       ,(layout-binary-tree-2-aux right (+ pos offset) (1- depth) (1+ level))))))))

;; Common Lisp
(defun tree-depth (tree)
  (if tree
      (labels ((frob (tree level)
		 (let ((left (cadr tree))
		       (right (caddr tree)))
		   (if (and (null left) (null right))
		     level
		     (max (frob left (1+ level))
			  (frob right (1+ level)))))))
	(frob tree 0))
      0))

(defun depth-of-most-left-node (tree)
  (if tree
      (labels ((frob (tree level)
		 (let ((left (cadr tree)))
		   (if left
		       (frob left (1+ level))
		       level))))
	(frob tree 0))
      0))

(defun layout-binary-tree-2 (tree)
  (let ((depth (tree-depth tree)))
    (labels ((frob (tree pos depth level)
	       (let ((left (cadr tree))
		     (right (caddr tree)))
		 (cond ((endp tree) '() )
		       ('T
			(let ((offset (expt 2 (1- depth))))
			  `((,pos . ,level)
			    ,(frob left  (- pos offset) (1- depth) (1+ level))
			    ,(frob right (+ pos offset) (1- depth) (1+ level)))))))))
      (frob tree 
	    (1+ (- (expt 2 (tree-depth tree))
		   (expt 2 (- (tree-depth tree) (depth-of-most-left-node tree)))))
	    depth 1))))

;; Scheme
(define (tree-depth tree)
  (if (null? tree)
      0
      (let frob ((tree tree)
		 (level 0))
	(let ((left  (list-ref tree 1 '() ))
	      (right (list-ref tree 2 '() )))
	  (if (and (null? left) (null? right))
	      level
	      (max (frob left (+ level 1))
		   (frob right (+ level 1))))))))

(define (depth-of-most-left-node tree)
  (if (null? tree)
      0
      (let frob ((tree tree)
		 (level 0))
	(let ((left (list-ref tree 1 '() )))
	  (if (null? left)
	      level
	      (frob left (+ 1 level)))))))

(define (layout-binary-tree-2 tree)
  (let ((depth (tree-depth tree)))
    (let frob ((tree tree)
	       (pos (+ 1 (- (expt 2 (tree-depth tree))
			    (expt 2 (- (tree-depth tree) 
				       (depth-of-most-left-node tree))))))
	       (depth depth)
	       (level 1)
	       (cont values))
      (let ((left (list-ref tree 1 '() ))
	    (right (list-ref tree 2 '() )))
	(cond ((null? tree) (cont '() ))
	      (else
	       (let ((offset (expt 2 (- depth 1))))
		 (frob left  (- pos offset) (- depth 1) (+ 1 level) 
		       (lambda (left)
			 (frob right (+ pos offset) (- depth 1) (+ 1 level)
			       (lambda (right)
				 (cont `((,pos . ,level) ,left ,right)))))))))))))

CADRでSICP 1.3

| 00:15 | CADRでSICP 1.3 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRでSICP 1.3 - わだばLisperになる

CADRでSICP Exercise 1.3.に挑戦 - Structure and Interpretation of Computer Programs

Exercise 1.3
3つの数のうち、大きい方2つの自乗の和を返す手続きを
つくれ。
解答
(defun sum-square-largest-2 (x y z)
  (if (and (<= x y) (<= x z))
      (+ (* y y) (* z z))
    (sum-square-largest-2 y z x)))

(defun sum-square-largest-2 (x y z)
  (cond ((and (<= x y) (<= x z))
	 (+ (* y y) (* z z)))
	((and (<= y z) (<= y z))
	 (+ (* z z) (* x x)))
	((and (<= z x) (<= z y))
	 (+ (* x x) (* y y)))))

偶々回答の前にJoe Marshall氏の小ネタ(日本語訳)を見てしまったため、

逆に普通の答え方の方がややこしく感じられるという罠。

(defun min-of-3 (x y z)
  (if (and (<= x y) (<= x z))
      x
    (min-of-3 y z x)))

の変形として捉えたってことなのかしらん。


CADRでSICP 1.2

| 00:13 | CADRでSICP 1.2 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRでSICP 1.2 - わだばLisperになる

CADRでSICP Exercise 1.2.に挑戦 - Structure and Interpretation of Computer Programs

Exercise 1.2
(5 + 4 + (2 - (3 - (6 + 4/ 5))))/ (3 * (6 - 2) * (2 - 7))
を前置記法で書け。
解答
(// (+ 5 4 (- 2 (- 3 (+ 6 (// 4 5)))))
    (* 3 (- 6 2) (- 2 7)))

//となっているのは、Maclisp〜LISP Machine LISP〜

Zetalispでは、/はエスケープ文字となっているため。

ちなみに(// 4 5)の結果は、0.となる。

2007-04-22

L-99 (72)

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

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

Prologの処理系をインストールして、Prologのプログラ

ムの動作が確認できるようになったので、放置していた

P72の動作を確認。

リストを先頭から順番にノード化していって最後が頂点

になるようなものを作成すれば良いだけらしいことが判

明したので、そのように作成。

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

P72


解答;; LISP Machine LISP
(defun bottom-up (lst)
  (if lst
      (do ((l lst (cdr l))
	   (retlst '() (cons (car l) retlst)))
	  ((null (cdr l)) `(,(car l) ,(nreverse retlst))))))

;; Common Lisp
(defun bottom-up (lst)
  (if lst
      `(,@(last lst) ,@(mapcar #'list (butlast lst)))))

;; Scheme 
(define (bottom-up lst)
  (if (null? lst)
      '()
      `(,(last lst) ,@(map list (drop-right lst 1)))))

2007-04-20

L-99 (64)

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

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

二分木を座標付きで下図のように表現すると、

N=(8,1)Q=(10,5)のようになる。

  1  2  3  4  5  6  7  8  9 10 11 12
1                 ,---(N)---------,
2     ,---------(K),   	    ,-----(U)
3  ,(C)------, 	   (M) 	 (P)---,     
4 A    	    ,-H	       	      ,-S
5	  ,G   	       	     Q 	 
6	E

ということで、二分木のデータを与えて、ノード名に座

標が入った同じ構造の二分木を返すというのが今回のお

題。

Lisp Machine Lispの回答では用意されていない関数を適宜定義してみた。

P64

解答
;; Lisp Machine Lisp
(defun range (start end)
  (do ((i start (1+ i))
       (retlst '()))
      ((> i end) (nreverse retlst))
    (push i retlst)))

(defun subseq (lst start end)
  (let ((len (length lst)))
    (cond ((or (minusp start) (minusp end))
	   (ferror nil "The value is out of range for ~S")
	  ((> end len) 
	   (ferror nil "The bounding indeces ~S and ~S are bad for sequence of length ~S" 
		   start end len))
	  ('T
	   (if lst
	       (do ((l (nthcdr start lst) (cdr l))
		    (c (- end start) (1- c))
		    (retlst '() ))
		   ((zerop c) (nreverse retlst))
		 (setq retlst (cons (car l) retlst)))))))))

(defun count-leaves-and-nods (tree)
  (if tree
      (+ 1
	 (count-leaves-and-nodes (second tree))
	 (count-leaves-and-nodes (third tree)))
    0))

(defun tree->numlist (tree)
  (let ((len (count-leaves-and-nodes tree)))
    (let ((numlist (range 1 len)))
      numlist)))

(defun layout-binary-tree (tree &optional (numlist (tree->numlist tree)) (level 1))
  (if (null tree)
      '()
    (let ((llen (count-leaves-and-nodes (cadr tree))))
      `((,(nth llen numlist) . ,level)		;root
	,(if (zerop llen)			;left
	     '()
	   (layout-binary-tree (cadr tree)
			       (subseq numlist 0 llen)
			       (1+ level)))
	,(layout-binary-tree (caddr tree)	;right
			     (nthcdr (1+ llen)  numlist)
			     (1+ level))))))

;; Common Lisp
(defun count-leaves-and-nodes (tree)
  (prog (total job tmp)
        (setq total 0)
	(push tree  job)
     l  (cond ((endp job) (return total)))
	(and (setq tmp (pop job))
	     (setq total (1+ total))
	     (push (caddr tmp) job)	;right
	     (push (cadr tmp)  job))	;left
	(go l)))

(defun tree->numlist (tree)
  (let ((len (count-leaves-and-nodes tree)))
    (let ((numlist (range 1 len)))
      numlist)))

(defun layout-binary-tree (tree)
  (labels ((frob (tree numlist level)
	     (if (endp tree)
		 '()
		 (let ((llen (count-leaves-and-nodes (cadr tree))))
		   `((,(nth llen numlist) . ,level) ;root
		     ,(if (zerop llen)		    ;left
			  '()
			  (frob (cadr tree) (subseq numlist 0 llen) (1+ level)))
		     ,(frob (caddr tree) (nthcdr (1+ llen)  numlist) (1+ level))))))) ;right
    (frob tree (tree->numlist tree) 1)))

;; Scheme 
(define (count-leaves-and-nodes tree)
  (let loop ((count 0) 
	     (job tree))
    (if (null? job)
	count
	(if (pair? (car job))		;list
	    (loop (+ count 1)		
		  (cdr `(,@(car job) ,@(cdr job))))
	    (if (null? (car job))	;atom
		(loop count (cdr job))
		(loop (+ count 1) (cdr job)))))))

(define (tree->numlist tree)
  (let ((len (count-leaves-and-nodes tree)))
    (let ((numlist (range 1 len)))
      numlist)))

(define (layout-binary-tree tree)
  (let frob ((tree tree)
	     (numlist (tree->numlist tree))
	     (level 1)
	     (cont values))
    (if (null? tree)
	(cont '())
	(let ((llen (count-leaves-and-nodes (cadr tree))))
	  (frob (cadr tree) (take numlist (+ llen 1)) (+ level 1) 
		(lambda (left)
		  (frob (caddr tree) (list-tail numlist  (+ llen 1)) (+ level 1) 
			(lambda (right)
			  (cont `((,(list-ref numlist llen) . ,level)
				  ,(if (zero? llen) '() left)
				  ,right))))))))))

2007-04-19

CADRでSICP Exercise 1.1

| 17:57 | CADRでSICP Exercise 1.1 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRでSICP Exercise 1.1 - わだばLisperになる

CADRでSICP Exercise 1.1.に挑戦 - Structure and Interpretation of Computer Programs

今回から1.1から順にSICPの問題に挑戦。

Exercise 1.1
インタプリタに式を入力して結果を観察。
10
-> 10.

(+ 5 3 4)
-> 12.

(- 9 1)
-> 8.

(+ (* 2 4) (- 4 6))
-> 6.

(defvar a 3)
-> NIL

(defvar b (+ a 1))
-> NIL

(= a b)
-> NIL

(if (and (> b a) (< b (* a b)))
    b
  a)
-> 4.

(cond ((= a 4) 6)
      ((= b 4) (+ 6 7 a))
      ('T 25))
-> 16.

(* (cond ((> a b) a)
	 ((< a b) b)
	 ('T -1))
   (+ a 1))
-> 16.

Lisp Machine Lisp固有と思われるところ:

・defvarが値をセットした時にNILを返すところ。

Maclispもそうなのかと思って試してみたら、Maclispは、

変数名を返す。Gaucheでも、SBCLでもそう。この辺は、

言語仕様なのか、処理系依存なのか調べないと分からな

い…けど…まあ…良いか(´▽`*)


L-99 (L-99.62B)

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

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

頂点をレベル1として、指定した階層のノードをリスト

にして返す関数の作成がお題。

P62B

解答

;; Lisp Machine Lisp
(defun atlevel (level tree)
  (cond ((null tree) '() )
	((= 1 level) `(,(car tree)))
	('T
	 `(,@(atlevel (1- level) (second tree))
	   ,@(atlevel (1- level) (third tree))))))

;; Common Lisp
(defun atlevel (level tree)
  (labels ((frob (level tree cont)
	     (cond ((endp tree) (funcall cont '() ))
		   ((= 1 level) (funcall cont `(,(car tree))))
		   ('T
		    (frob (1- level) 
			  (second tree) 
			  #'(lambda (l)
			      (frob (1- level)
				    (third tree)
				    #'(lambda (r)
					(funcall cont `(,@l ,@r))))))))))
    (frob level tree #'values)))

;; Scheme
(define (atlevel level tree)
  (let frob ((level level)
	     (tree tree)
	     (cont values))
    (cond ((null? tree) (cont '() ))
	  ((= 1 level) (cont `(,(car tree))))
	  (else
	   (frob (- level 1) 
		 (cadr tree) 
		 (lambda (l)
		   (frob (- level 1)
			 (caddr tree)
			 (lambda (r)
			   (cont `(,@l ,@r))))))))))

L-99 (62)

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

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

今回のお題は、P61の逆で、葉っぱじゃなくて節を数え

よとのこと。

P62

解答
;; Lisp Machine Lisp
(defun internals (tree)
  (if (null tree)
      '()
    (if (leafp tree)
	'()
      `(,(car tree)
	,@(internals (cadr tree))
	,@(internals (caddr tree))))))

;; Common Lisp
(defun internals (tree)
  (labels ((cpass (tree cont)
	     (if (endp tree)
		 (funcall cont '() )
		 (if (leafp tree)
		     (funcall cont '() )
		     (cpass (second tree)
			    #'(lambda (l)
				(cpass (third tree)
				       #'(lambda (r)
					   (funcall cont `(,(car tree) ,@l ,@r))))))))))
    (cpass tree #'values)))

;; Scheme
(define (internals tree)
  (let cpass ((tree tree)
	      (cont values))
    (if (null? tree)
	(cont '() )
	(if (leaf? tree)
	    (cont '() )
	    (cpass (cadr tree)
		   (lambda (l)
		     (cpass (caddr tree)
			    (lambda (r)
			      (cont `(,(car tree) ,@l ,@r))))))))))

L-99 (61A)

| 14:48 | L-99 (61A) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (61A) - わだばLisperになる

L-99 P61Aに挑戦を訂正 - L-99:Ninety-Nine Lisp Problems

P61Aもまた訂正。前の回答では、単なるflattenになっ

てました。そうだと思ってました( ´)Д(`)

P61A

解答
;; Lisp Machine Lisp
(defun leaves (tree)
  (if (null tree)
      '()
    (if (leafp tree)
	`(,(car tree))
      `(,@(leaves (cadr tree))
	,@(leaves (caddr tree))))))

;; Common Lisp
(defun leaves (tree)
  (labels ((cpass (tree cont)
	     (if (endp tree)
		 (funcall cont '() )
		 (if (leafp tree)
		     (funcall cont `(,(car tree)))
		     (cpass (second tree)
			    #'(lambda (l)
				(cpass (third tree)
				       #'(lambda (r)
					   (funcall cont `(,@l ,@r))))))))))
    (cpass tree #'values)))

;; Scheme
(define (leaves tree)
  (let cpass ((tree  tree)
	      (cont values))
    (if (null? tree)
	(cont '() )
	(if (leaf? tree)
	    (cont `(,(car tree)))
	    (cpass (cadr tree)
		   (lambda (l)
		     (cpass (caddr tree)
			    (lambda (r)
			      (cont `(,@l ,@r))))))))))
;

L-99 (訂正L-99.61)

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

L-99 P61に挑戦を訂正 - L-99:Ninety-Nine Lisp Problems

P62の回答を作成しようと問題を読んでいて問題の意味

を取り違えていたことに気付いた。

葉っぱと節の定義を良く把握していなかったため、葉っ

ぱと節を区別しないで、実装していた(:.;゜;Д;゜;.:)

やり直しました。

P61

解答
;; Lisp Machine Lisp
(defun leafp (tree)
  (and tree
       (car tree)
       (atom (car tree))
       (null (cadr tree))
       (null (caddr tree))))

(defun count-leaves (tree)
  (if (null tree)
      0
    (if (leafp tree)
	1
      (+ (count-leaves (cadr tree))
	 (count-leaves (caddr tree))))))

;; Common Lisp
(defun leafp (tree)
  (and tree
       (car tree)
       (atom (car tree))
       (endp (cadr tree))
       (endp (caddr tree))))

(defun count-leaves (tree)
  (labels ((cpass (tree cont)
	     (if (endp tree)
		 (funcall cont 0)
		 (if (leafp tree)
		     (funcall cont 1)
		     (cpass (second tree)
			    #'(lambda (l)
				(cpass (third tree)
				       #'(lambda (r)
					   (funcall cont (+ l r))))))))))
    (cpass tree #'values)))

;; Scheme
(define (leaf? tree)
  (and (not (null? tree))
       (not (null? (car tree)))
       (not (pair? (car tree)))
       (null? (cadr tree)))
       (null? (caddr tree)))

(define (count-leaves tree)
  (let cpass ((tree tree)
	      (cont values))
    (if (null? tree)
	(cont 0)
	(if (leaf? tree)
	    (cont 1)
	    (cpass (cadr tree)
		   (lambda (l)
		     (cpass (caddr tree)
			    (lambda (r)
			      (cont (+ l r))))))))))
;

2007-04-18

L-99 (61A)

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

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

二分木の内容をリストにするというお題。

継続渡しスタイルで書いてみた。

残念ながら、CADRでそのまま試すとPDL-Overflow(スタッ

クオーバーフロー)になってしまうので、Lisp Machine

Lispでは、普通に書いてみた。

P61A

;; Lisp Machine Lisp
(defun leaves (tree)
  (if (null tree)
      '()
    `(,(car tree) 
      ,@(leaves (cadr tree))
      ,@(leaves (caddr tree)))))

;; Common Lisp
(defun leaves (tree)
  (labels ((cpass (tree cont)
	     (if (endp tree)
		 (funcall cont '())
		 (cpass (cadr tree) 
			#'(lambda (m)
			    (cpass (caddr tree) 
				   #'(lambda (n)
				       (funcall cont `(,(car tree) ,@m ,@n)))))))))
    (cpass tree #'values)))

;; Scheme
(define (leaves tree)
  (let cpass ((tree tree)
	      (cont values))
    (if (null? tree)
	(cont '())
	(cpass (cadr tree) 
	       (lambda (m)
		 (cpass (caddr tree) 
			(lambda (n)
			  (cont `(,(car tree) ,@m ,@n)))))))))

2007-04-17

L-99 (61)

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

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

また難しいのに遭遇したので、スキップ。

P61は二分木の葉っぱの数を勘定する関数の作成が課題。

再帰的じゃない書き方にも挑戦してみた。

P61

解答
;; Lisp Machine Lisp
(defun count-leaves (tree)
  (if (null tree)
      0
    (+ 1
       (count-leaves (second tree))
       (count-leaves (third tree)))))

;; Common Lisp
(DEFUN COUNT-LEAVES (TREE)
  (PROG (TOTAL JOB TMP)
        (SETQ TOTAL 0)
	(PUSH TREE  JOB)
     L  (COND ((ENDP JOB) (RETURN TOTAL)))
	(AND (SETQ TMP (POP JOB))
	     (SETQ TOTAL (1+ TOTAL))
	     (PUSH (CADDR TMP) JOB)	;Right
	     (PUSH (CADR TMP)  JOB))	;Left
	(GO L)))

;; Scheme
(define (count-leaves tree)
  (let loop ((count 0) 
	     (job tree))
    (if (null? job)
	count
	(if (pair? (car job))		;list
	    (loop (+ count 1)		
		  (cdr `(,@(car job) ,@(cdr job))))
	    (if (null? (car job))	;atom
		(loop count (cdr job))
		(loop (+ count 1) (cdr job)))))))

2007-04-16

L-99 (57)

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

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

今回のお題は、数値のリストを二分探索木的に配置した

二分木を作成せよとのこと。

今回遭遇した謎:

問題自体には全く関係ないが、Scheme(Gauche)で、

(let ((foo 'foo))
  (let ((bar (list foo ())))
    `(,bar ,bar)))

の様に書くと、

(#0=(foo ()) #0#)

のような値が返ってくる。

DrSchemeでも、

(shared ((-1- (list 'foo empty) ) ) (list -1- -1-) )

の様になる。MzSchemeでは、意図通りに((foo () ) (foo () ) )

Schemeでは、(list foo foo)の代わりに、`(,foo ,foo)

のような書き方は良くないのだろうか。

P57

解答
;; Lisp Machine Lisp
(defun add-leaf (leaf tree)
  (let ((root (car tree))
	(left (cadr tree))
	(right (caddr tree))
	(node `(,leaf () ())))
    (if (<= leaf root)
	(if (null left)
	    `(,root ,node ,right)
	  `(,root ,(add-leaf leaf left) ,right))
      (if (null right)
	  `(,root ,left ,node)
	`(,root ,left ,(add-leaf leaf right))))))

(defun construct (lst)
  (and lst
       (do ((l (cdr lst) (cdr l))
	    (retlst `(,(car lst) () ())
		    (add-leaf (car l) retlst)))
	   ((null l) retlst))))

;; Common Lisp
(defun add-leaf (leaf tree)
  (let ((root (car tree))
	(left (cadr tree))
	(right (caddr tree))
	(node `(,leaf () ())))
    (if (<= leaf root)
	(if (endp left)
	    `(,root ,node ,right)
	    `(,root ,(add-leaf leaf left) ,right))
	(if (endp right)
	    `(,root ,left ,node)
	    `(,root ,left ,(add-leaf leaf right))))))

(defun construct (lst)
  (reduce #'(lambda (lst leaf) (add-leaf leaf lst))
	  (cdr lst) :initial-value `(,(car lst) () ())))  

;; Scheme
(define (add-leaf leaf tree)
  (let ((root  (list-ref tree 0))
	(left  (list-ref tree 1))
	(right (list-ref tree 2))
	(node (list leaf () ())))
    (if (<= leaf root)
	(if (null? left)
	    `(,root ,node ,right)
	    `(,root ,(add-leaf leaf left) ,right))
	(if (null? right)
	    `(,root ,left ,node)
	    `(,root ,left ,(add-leaf leaf right))))))

(define (construct lst)
  (fold add-leaf `(,(car lst) () ()) (cdr lst)))
;

2007-04-15

L-99 (56)

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

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

50番台の問題が難しかったので、飛ばして70番台から進

めていたけれど、80番台も難しいので、50番台から解答

できそうな問題に挑戦することに。

今回は、二分木の対称性を調べる関数の作成が問題。ノー

ドのアイテムまで完全に同じかどうかではなく、骨格が

同じならば、真と判定せよとのこと。

CADRいじるのが楽しいので、Lisp Machine Lispでも回

答。

Lisp Machine Lispにはendpがないので、作ってみた。

そこで、listpが空リストでtを返さないことを発見。や

やこしい。

P56

解答
;; Lisp Machine Lisp / Common Lisp
(defun mirror (tree)
  (if (endp tree)
      '()
    (destructuring-bind (root l r)
			tree
      `(,root ,(mirror r) ,(mirror l)))))

(defun skeleton (tree)
  (if (endp tree)
      '()
    (destructuring-bind (root l r)
			tree
      `(x ,(skeleton l) ,(skeleton r)))))

(defun symmetric (tree)
  (let ((skel (skeleton tree)))
    (equal skel (mirror skel))))

; ENDP / Lisp Machine Lisp
(defun endp (obj)
  (if (listp obj)
      (null obj)
    (if (null obj)
	t
      (ferror nil "The value ~S is not of type LIST." obj))))

;; Scheme 
(use util.match)

(define (mirror tree)
  (if (null? tree)
      '()
      (match-let (((root l r) tree))
	`(,root ,(mirror r) ,(mirror l)))))

(define (skeleton tree)
  (if (null? tree)
      '()
      (match-let (((root l r) tree))
	`(x ,(skeleton l) ,(skeleton r)))))

(define (symmetric tree)
  (let ((skel (skeleton tree)))
    (equal? skel (mirror skel))))

2007-04-13

CADRでSICP Exercise 3.1

| 22:38 | CADRでSICP Exercise 3.1 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRでSICP Exercise 3.1 - わだばLisperになる

CADRでSICP Exercise 3.1.に挑戦 - Structure and Interpretation of Computer Programs

挑戦しているL-99も段々問題が難しくなり、また、

Prologの問題をLispで解こうというだけになかなか一筋

縄では行かず、若干煮詰り気味な感じ。

そこで、計算機プログラムの構造と解釈(通称SICP)にも

挑戦してみることに。

一捻りして、LispMで回答を作成することにしてみた。

使用するLispM環境は、CADRのエミュレータ。

1977〜1984位までは、最先端のLisp環境だった模様。

CADRのLispの処理系は、Maclisp系のLisp Machine Lisp

(Zetalispの前身)。

Schemeや、Common Lispと違うところは、レキシカルス

コープではないところ。でも、クロージャを作成する機

構は存在し、Common Lispにかなり近いので、なんとか

なるだろうと。

ということで、今回は、Exercise 3.1に挑戦。次回から

Exercise 1.1から順番に回答を作成予定。

お題:局所状態変数の実現(?)
(define A (make-accumulator) 5)

(A 10)
=> 15

(A 20)
=> 25
を実現するmake-accumulatorを作成せよ。
解答
;; Lisp Machine Lisp
(defun make-accumulator (init)
  (let-closed ((acc init))
    #'(lambda (n)
	(setq acc (+ acc n)))))

;; Scheme
(define (make-accumulator init)
  (let ((acc init))
    (lambda (n)
      (set! acc (+ acc n)))))

面白いところ:

Lisp Machine Lispはダイナミックスコープなので、ク

ロージャを作成するには、それ用の関数等を使うらしい。

主な関数は、そのものずばりな名前のclosure。

let-closedは、マクロで使い勝手的には、Common Lisp

や、Schemeのletと同じ感じ。詳細は、

マニュアル参照

クロージャを操作する関数が色々あり、クロージャの中

身の変数の状態とか覗いてみれたり、変更できたりする。

(setq A (make-accumulator 5.))
(funcall A 10.)
=> 15.

(closure-variables A)
=> acc

(closure-function A)
=> (lambda (n) (setq acc **))

(closure-bindings a)
=> CADRでは未実装?

(closure-alist A)
=> ((acc . 15))

(symeval-in-closure A 'acc)
=> 15

(set-in-closure A 'acc 100.)
=> 100.

(funcall A 10.)
=> 110.

(boundp-in-closure a 'acc)
=> CADRでは未実装?

(locate-in-closure a 'acc)
->#<DTP-LOCATIVE 222343434>

(makeunbound-in-closure a 'acc)
=> CADRでは未実装?

(copy-closure a)
=> CADRでは未実装?

L-99 (73)

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

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

P72の問題に挑戦してみたけれど、問題の意図が分から

なかったので、飛してP73に挑戦。

お題は、多分岐ツリーをLisp的なリスト表現にする関数

の作成と、その逆変換をする関数の作成。

問題が進むにつれ、段々解答が正しいのか分からなくなっ

てきた。テストケースとかちゃんと書かないと駄目なの

かもしれない。

P73

解答
;; Common Lisp
(defun multiway-tree->lispy-token-list (tree)
  (cond	((atom tree) tree)
	((= 1 (length tree)) (car tree))
	('T `(,(multiway-tree->lispy-token-list (car tree))
	      ,@(mapcar #'multiway-tree->lispy-token-list
			(cdr tree))))))

(defun lispy-token-list->multiway-tree (tree)
  (labels ((frob (tree depth)
	     (cond ((and (zerop depth) (atom tree)) `(,tree))
		   ((atom tree) tree)
		   ('T `(,(frob (car tree) (1+ depth))
			  ,@(mapcar #'(lambda (n) 
					(if (atom n) 
					    `(,n) 
					    (frob n (1+ depth))))
				    (cdr tree)))))))
    (frob tree 0)))

;; Scheme 
(define (multiway-tree->lispy-token-list tree)
  (cond ((not (pair? tree)) tree)
	((= 1 (length tree)) (car tree))
	(else `(,(multiway-tree->lispy-token-list (car tree))
		,@(map multiway-tree->lispy-token-list
		       (cdr tree))))))

(define (lispy-token-list->multiway-tree tree)
  (let frob ((tree tree) 
	     (depth 0))
    (cond ((and (zero? depth) (not (pair? tree))) 
	   `(,tree))
	  ((not (pair? tree)) 
	   tree)
	  (else 
	   `(,(frob (car tree) (+ depth 1))
	     ,@(map (lambda (n) 
		      (if (pair? n) 
			  (frob n (+ depth 1))
			  `(,n)))
		    (cdr tree)))))))

2007-04-12

L-99 (71)

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

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

今回のお題は、多分岐ツリーで各ノードの根までの距離

のツリー全体の総和を求める関数の作成。

素直に作成。

P71

解答
;; Common Lisp
(defun internal-path-length (tree)
  (labels ((ipl (tree depth)
	     (cond ((> 2 (length tree)) 0)
		   ('T (apply #'+ 
			      (1- (length tree)) 
			      (mapcar #'(lambda (l)
					  (+ depth (ipl l (1+ depth))))
				      (cdr tree)))))))
    (ipl tree 0)))

;; Scheme 
(define (internal-path-length tree)
  (let ipl ((tr tree) (depth 0))
    (cond ((> 2 (length tr)) 0)
	  (else (apply +
		       (- (length tr) 1)
		       (map (lambda (l)
			      (+ depth (ipl l (+ 1 depth))))
			    (cdr tr)))))))

2007-04-11

L-99 (70)

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

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

引き続き、70番台の問題に挑戦。70番台は、多分岐ツ

リーの問題。

今回の回答は、リスト構造を解析しないで、与えられた

文字列を無理矢理リスト表現に変換するという反則攻撃。

文字列の形式が正しくないとエラーになるので、例外処

理もしてみた。nilを返すだけだけども。

P70

解答
;; Common Lisp
(defun node-string->tree (string)
  (values 
   (handler-case 
       (read-from-string
	(coerce 
	 (let ((retlst '()))
	   (mapc #'(lambda (c)
		     (setq retlst (if (char= #\^ c)
				      `(,@retlst #\))
				      `(,@retlst #\( ,c))))
		 (coerce string 'list))
	   retlst)
	 'string))
     (end-of-file nil nil))))

;; Scheme (Gauche)
(define node-string->tree 
  (lambda (str)
    (guard (err ((<read-error> err) #f))
	   (read-from-string
	    (list->string
	     (let ((retlst '()))
	       (for-each (lambda (c)
			   (set! retlst (if (char=? #\^ c)
					    `(,@retlst #\))
					    `(,@retlst #\( ,c))))
			 (string->list str))
	       retlst))))))

2007-04-09

L-99 (70C)

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

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

引き続き、解けそうな問題ということで、P70Cの解答を

作成。しかし、flow pattern (o,i)って何物だ

P70C

解答
;; Common Lisp
(defun nnodes (tree)
  (and (is-multiway-tree tree)
       (let ((rest-tree (cdr tree)))
	 (apply #'+ 1
		(if (null rest-tree)
		    '(0)
		    (mapcar #'nnodes rest-tree))))))

;; Scheme
(define nnodes
  (lambda (tree)
    (and (is-multiway-tree tree)
	 (let ((rest-tree (cdr tree)))
	   (apply + 1
		  (if (null? rest-tree)
		      '(0)
		      (map nnodes rest-tree)))))))

; 前のis-multiway-treeの定義では、'()を与えられた
; 場合にエラーとなるので、carからGauche拡張ありの
; list-refへ変更
(define is-multiway-tree
  (lambda (obj)
    (let/cc exit
      (and (not (list? (list-ref obj 0 '())))
	   (dolist (o (cdr obj) #t)
		   (or (and (list? o)
			    (is-multiway-tree o))
		       (exit #f)))))))

2007-04-08

L-99 (70B)

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

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

P55に挑戦していたけれど、12時間考えても全然歯が立

たない!

問題の概要はといえば、

1、与えられた数の葉っぱを二分木の左右に均等に振り

分ける (差は右と左で葉っぱ一枚以内)

2、1が成り立つすべての組み合わせを出力せよ。

(バックトラックを使って)

うぁぁぁぁわかんねー ヽ(`Д´)ノ=3

ということで、失意の中、解けそうな問題ということで、

いきなりP70Bの回答を作成

P70B

解答
;; Common Lisp
(defun is-multiway-tree (obj)
  (and (not (listp (car obj)))
       (dolist (o (cdr obj) t)
	 (or (and (listp o)
		  (is-multiway-tree o))
	     (return-from is-multiway-tree nil)))))

;; Scheme
(define is-multiway-tree
  (lambda (obj)
    (let/cc exit
      (and (not (list? (car obj)))
	   (dolist (o (cdr obj) #t)
		   (or (and (list? o)
			    (is-multiway-tree o))
		       (exit #f)))))))

2007-04-07

L-99 (54)

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

L-99 54問目に挑戦 - L-99:Ninety-Nine Lisp Problems

P54A

解答
;; Common Lisp
(defun istree (obj)
  (flet ((isnode (node)
	   (or (null node) (istree node))))
    (and (listp obj)
	 (= 3 (length obj))
	 (equal '(nil t t) (mapcar #'isnode obj)))))

;; Scheme
(define (istree obj)
  (let ((isnode 
	 (lambda (node)
	   (or (null? node) (istree node)))))
    (and (list? obj)
	 (= 3 (length obj))
	 (equal? '(#f #t #t) (map isnode obj)))))

また番号が飛んで54問目。今回から二分木の章。今回の

お題は、二分木をリストで表現して、それが二分木の形

式になっているかをチェックするというもの。いまいち

イメージが掴めないが、とりあえず作成

2007-04-06

L-99 (50)

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

L-99 50問目に挑戦 - L-99:Ninety-Nine Lisp Problems

P50

解答
;;; Common Lisp
(defun for-each-tree (f g n tree)
  (cond ((not (listp tree)) (funcall f tree))		
	((endp tree) n)
	('t (funcall g (for-each-tree f g n (car tree))
		     (for-each-tree f g n (cdr tree))))))

(defun make-frequency-list (lst &aux (retlst '()))
  (dolist (item lst retlst)
    (let ((found-item (assoc item retlst)))
      (if found-item
	  (incf (cdr found-item))
	  (setf retlst `(,@retlst (,item . 1)))))))

(defun make-huffman-tree (lst)
  (if (= (length lst) 1)
    (caar lst)
    (make-huffman-tree
     (destructuring-bind (a b &rest c)
	 (sort lst #'(lambda (a b) (< (cdr a) (cdr b))))
       `(((,(car a) ,(car b)) . ,(+ (cdr a) (cdr b))) ,@c)))))

(defun huffman-tree->code (tree &optional (code ""))
  (cond ((not (listp tree)) `(,tree ,code))
	((endp tree) '())
	('t `(,(huffman-tree->code (car tree) (concatenate 'string code "1"))
	       (,(huffman-tree->code (cadr tree) (concatenate 'string code "0")))))))

(defun flatten-tree (tree)
  (for-each-tree #'list #'append '() tree))

(defun rebuild-list (lst)
  (do ((l lst (cddr l))
       (retlst '() `(,@retlst (,(car l) ,(cadr l)))))
      ((endp l) retlst)))

(defun huffman-encode (lst)
  (rebuild-list
   (flatten-tree
    (huffman-tree->code 
     (make-huffman-tree 
      (make-frequency-list lst))))))

(defun pp-huffman-code (lst)
  (mapc #'(lambda (item)
	    (format t "~A => ~A~%" (car item) (cadr item)))
	lst))

; 使い方:
; (pp-huffman-code
; (sort (huffman-encode *testdata*) #'(lambda (a b) (char< (car a) (car b)))))

;;; Scheme
(use util.match)

;; util
(define (for-each-tree f g n tree)
  (cond ((null? tree) n)
	((not (pair? tree)) (f tree))
	(else (g (for-each-tree f g n (car tree))
		 (for-each-tree f g n (cdr tree))))))

(define (make-frequency-list lst)
  (let ((retlst '()))
    (dolist (item lst retlst)
	    (let ((found-item (assoc item retlst)))
	      (if found-item
		  (inc! (cdr found-item))
		  (set! retlst `(,@retlst (,item . 1))))))))

(define (make-huffman-tree lst)
  (if (= (length lst) 1)
      (caar lst)
      (make-huffman-tree
       (match-let (((a b . c) (sort lst (lambda (a b) (< (cdr a) (cdr b))))))
		  `(((,(car a) ,(car b)) . ,(+ (cdr a) (cdr b))) ,@c)))))

(define (huffman-tree->code tree)
  (let tree->code ((tree tree)
		   (code ""))
    (cond ((not (list? tree)) `(,tree ,code))
	  ((null? tree) '())
	  (else `(,(tree->code (car tree) (string-append code "1"))
		  (,(tree->code (cadr tree) (string-append code "0"))))))))

(define (flatten-tree tree)
  (for-each-tree list append '() tree))

(define (rebuild-list lst)
  (do ((l lst (cddr l))
       (retlst '() `(,@retlst (,(car l) ,(cadr l)))))
      ((null? l) retlst)))

(define (huffman-encode lst)
  (rebuild-list
   (flatten-tree
    (huffman-tree->code 
     (make-huffman-tree 
      (make-frequency-list lst))))))

(define (pp-huffman-code lst)
  (for-each (lambda (item)
	      (format #t "~A => ~A~%" (car item) (cadr item)))
	    lst))
;

今回は、データをハフマン符号化してみようというお題。

ハフマン符号とはデータ圧縮などで用いられる符号化方

式で、JPEGとか、LHAで使われているらしい。

今回も日本語版のWikipediaに解説があったので、その

まま実装していたが、そのまま作ると全然圧縮してくれ

てないことに気付いた。あの記載は正しいのだろうか。

良く分かんないので、他のサイトを参照しつつ再度挑戦

しなんとか作成。Scheme版は殆どCLの写し。

また、今回木構造を操作する必要があったので、

(Scheme)(Lisp)さんのところの(高階関数の使い方)から、

for-each-treeとflatten-treeを拝借した。

何が何だか分からない仕上がり。

関数内関数に纏めた方が良いものもあるような、そうで

もないような。

2007-04-04

L-99 (49)

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

L-99 49問目に挑戦 - L-99:Ninety-Nine Lisp Problems

P49

解答
;;; Common Lisp
(defun bin->gray (n)
  (logxor (ash n -1) n))

(defun nbit-gray (n)
  (do ((i 0 (1+ i))
       (retlst '() `(,@retlst ,(format nil (format nil "~~~d,'0b" n) (bin->gray i)))))
      ((= i (expt 2 n) retlst))))

;;; Scheme
(define (bin->gray n)
  (logxor (ash n -1) n))

(define (nbit-gray n)
  (let loop ((i 0) (retlst '()))
    (if (= i (expt 2 n))
	retlst
	(loop (1+ i)
	      `(,@retlst ,(format #f (format #f "~~~d,'0b" n) (bin->gray i)))))))

今回のお題は、2進数値->グレイコードへの変換。グレ

イコードが何だか分からなかったので、調べつつ作成。

グレイコードには面白い特徴があるっぽい。この問題集

は色々ためになるな。

参考にしたページに2進数値からの変換は、右ビットシ

フトしてXORを取れば良いとあったのでそのままお気軽

に実装。

なんとなく問題の意図を無視してしまっている気はすれ

ど良しとしよう。

また、キャッシュを取って効率を上げる点についても、

今回の方法だと成り立つような成り立たないような。

2007-04-03

L-99 (48)

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

L-99 48問目に挑戦 - L-99:Ninety-Nine Lisp Problems

P48

解答
;;; Common Lisp
(load "./make-truth-table")

(defun table (size expr)
  (mapcar #'(lambda (item)
	      `(,@item ,(apply expr item)))
	  (make-truth-table size)))

(defun pp-table (lst)
  (dolist (l lst)
    (format t "~{~A ~} -> ~{~A~}~%" (butlast l) (last l))))

;;; Scheme
(load "./make-truth-table")

(define table
  (lambda (size expr)
    (map (lambda (item)
	   `(,@item ,(apply expr item)))
	 (make-truth-table size #t #f))))

(define pp-table
  (lambda (lst)
    (let loop ((l lst))
      (if (null? l)
	  (values)
	  (let ((m (car l)))
	    (format #t "~A -> ~A~%" (drop-right m 1) (last m))
	    (loop (cdr l)))))))

P47は、与える論理式を中間記法で与えられるようにす

るという問題。これは自分の手に余るので、後回し後回

し。それで、P48は真理表のテーブルをリストで与える

ように拡張せよ、というもの。

ちょっとした疑問があって、それは問題では、[A,B,C]

というようにリストを与えるようになっているところ。

Prologでは、こういう表現で良いのかもしれないけれど、

真偽表なので、真か偽かの2値しか取らない筈であり、

要素の数が分かれば良いのではないかしらと思ったり。

そんな訳で、要素の数だけ指定するように作ってみた。


L-99 (46)

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

L-99 46問目に挑戦 - L-99:Ninety-Nine Lisp Problems

P46

解答
;;; Common Lisp
(defun nth-truth (size num &optional (true t) (false nil))
  (do* ((j size (1- j))
	(retlst '() `(,@retlst 
		    ,(if (evenp (floor num (expt 2 j))) true false))))
       ((zerop j) retlst)))

(defun make-truth-table (size &optional (true t) (false nil))
  (do ((i 0 (1+ i))
       (retlst '() `(,@retlst ,(nth-truth size i true false))))
      ((= i (expt 2 size)) retlst)))       

(defun table/3 (a b expr)
  (let ((size 2))
    (mapcar #'(lambda (pattern)
		(destructuring-bind (a b)
		    pattern
		  `(,a ,b ,(funcall expr a b))))
	    (make-truth-table size a b))))

(defun pp-table/3 (lst)
  (dolist (l lst)
    (destructuring-bind (a b c)	l
      (format t "~A ~A -> ~A~%" a b c))))

(defun and/2 (a b) 
  (if a b a))

(defun or/2 (a b)
  (if a a b))

(defun impl/2 (a b)
  (or/2 (not a) b))

(defun nand/2 (a b)
  (not (if a b a)))

(defun nor/2 (a b)
  (not (if a a b)))

(defun equ/2 (a b)
  (or/2 (and/2 a b)
	(and/2 (not a) (not b))))

(defun xor/2 (a b)
  (not (or/2 (and/2 a b)
	     (and/2 (not a) (not b)))))

;;; Scheme
(use util.match)

(define nth-truth
  (lambda (size num true false)
    (let loop ((j size)
	       (retlst '()))
      (if (zero? j)
	  retlst
	  (loop (- j 1) 
		`(,@retlst ,(if (even? (quotient num (expt 2 (- j 1))) )
				true 
				false)))))))

(define make-truth-table
  (lambda (size true false)
    (let loop ((i 0)
	       (retlst '()))
      (if (= i (expt 2 size))
	  retlst
	  (loop (+ i 1)
		`(,@retlst ,(nth-truth size i true false)))))))

(define table/3
  (lambda (a b expr)
    (let ((size 2))
      (map (lambda (pattern)
	     (match-let (((a b) pattern))
			`(,a ,b ,(expr a b))))
	   (make-truth-table size a b)))))

(define pp-table/3 
  (lambda (lst)
    (for-each (lambda (i)
		(match-let (((a b c) i))
			   (format #t "~A ~A -> ~A~%" a b c)))
	      lst)
    (values)))

(define (and/2 a b) 
  (if a b a))

(define (or/2 a b)
  (if a a b))

(define (impl/2 a b)
  (or/2 (not a) b))

(define (nand/2 a b)
  (not (if a b a)))

(define (nor/2 a b)
  (not (if a a b)))

(define (equ/2 a b)
  (or/2 (and/2 a b)
	(and/2 (not a) (not b))))

(define (xor/2 a b)
  (not (or/2 (and/2 a b)
	     (and/2 (not a) (not b)))))
;

今回から論理と符号化のセクション。番号も飛んで46番

から開始。implがなんだか良く分からなかったが、

Wikipediaを参照してなんとか作成。