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